Add unique package identifiers (InstalledPackageId) in the package DB

See commentary at
http://hackage.haskell.org/trac/ghc/wiki/Commentary/Packages

10 files changed, 210 insertions, 164 deletions

diff --git a/compiler/ghc.mk b/compiler/ghc.mk
index 64b1213c08..e8c487f32e 100644
--- a/compiler/ghc.mk
+++ b/compiler/ghc.mk
@@ -464,6 +464,7 @@ $(eval $(call compiler-hs-dependency,PrimOp,$(PRIMOP_BITS)))
 ifneq "$(ProjectPatchLevel)" "0"
 compiler/stage1/inplace-pkg-config-munged: compiler/stage1/inplace-pkg-config
 	sed -e 's/^\(version: .*\)\.$(ProjectPatchLevel)$$/\1/' \
+	    -e 's/^\(id: .*\)\.$(ProjectPatchLevel)$$/\1/' \
 	    -e 's/^\(hs-libraries: HSghc-.*\)\.$(ProjectPatchLevel)$$/\1/' \
 	  < $< > $@
 	"$(compiler_stage1_GHC_PKG)" update --force $(compiler_stage1_GHC_PKG_OPTS) $@
diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs
index 419cb4f968..4c85ac6940 100644
--- a/compiler/ghci/Linker.lhs
+++ b/compiler/ghci/Linker.lhs
@@ -51,6 +51,7 @@ import ErrUtils
 import SrcLoc
 import qualified Maybes
 import UniqSet
+import FiniteMap
 import Constants
 import FastString
 import Config		( cProjectVersion )
@@ -973,23 +974,25 @@ linkPackages dflags new_pkgs = do
 linkPackages' :: DynFlags -> [PackageId] -> PersistentLinkerState
              -> IO PersistentLinkerState
 linkPackages' dflags new_pks pls = do
-    let pkg_map = pkgIdMap (pkgState dflags)
-
-    pkgs' <- link pkg_map (pkgs_loaded pls) new_pks
-
+    pkgs' <- link (pkgs_loaded pls) new_pks
     return $! pls { pkgs_loaded = pkgs' }
   where
-     link :: PackageConfigMap -> [PackageId] -> [PackageId] -> IO [PackageId]
-     link pkg_map pkgs new_pkgs =
-         foldM (link_one pkg_map) pkgs new_pkgs
+     pkg_map = pkgIdMap (pkgState dflags)
+     ipid_map = installedPackageIdMap (pkgState dflags)
+
+     link :: [PackageId] -> [PackageId] -> IO [PackageId]
+     link pkgs new_pkgs =
+         foldM link_one pkgs new_pkgs
 
-     link_one pkg_map pkgs new_pkg
+     link_one pkgs new_pkg
 	| new_pkg `elem` pkgs	-- Already linked
 	= return pkgs
 
 	| Just pkg_cfg <- lookupPackage pkg_map new_pkg
 	= do { 	-- Link dependents first
-	       pkgs' <- link pkg_map pkgs (map mkPackageId (depends pkg_cfg))
+               pkgs' <- link pkgs [ Maybes.expectJust "link_one" $
+                                    lookupFM ipid_map ipid
+                                  | ipid <- depends pkg_cfg ]
 		-- Now link the package itself
 	     ; linkPackage dflags pkg_cfg
 	     ; return (new_pkg : pkgs') }
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 55dc8c77da..f4975f0992 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -2058,13 +2058,7 @@ ignorePackage p =
   upd (\s -> s{ packageFlags = IgnorePackage p : packageFlags s })
 
 setPackageName :: String -> DynFlags -> DynFlags
-setPackageName p
-  | Nothing <- unpackPackageId pid
-  = ghcError (CmdLineError ("cannot parse \'" ++ p ++ "\' as a package identifier"))
-  | otherwise
-  = \s -> s{ thisPackage = pid }
-  where
-        pid = stringToPackageId p
+setPackageName p s =  s{ thisPackage = stringToPackageId p }
 
 -- If we're linking a binary, then only targets that produce object
 -- code are allowed (requests for other target types are ignored).
diff --git a/compiler/main/PackageConfig.hs b/compiler/main/PackageConfig.hs
index f3cede68da..79521c7df7 100644
--- a/compiler/main/PackageConfig.hs
+++ b/compiler/main/PackageConfig.hs
@@ -7,7 +7,7 @@ module PackageConfig (
     -- $package_naming
     
 	-- * PackageId
-	mkPackageId, packageConfigId, unpackPackageId,
+	mkPackageId, packageConfigId,
 	
 	-- * The PackageConfig type: information about a package
 	PackageConfig,
@@ -28,7 +28,6 @@ import Distribution.ModuleName
 import Distribution.Package hiding (PackageId)
 import Distribution.Text
 import Distribution.Version
-import Distribution.Compat.ReadP
 
 -- -----------------------------------------------------------------------------
 -- Our PackageConfig type is just InstalledPackageInfo from Cabal.  Later we
@@ -62,15 +61,6 @@ mkPackageId = stringToPackageId . display
 packageConfigId :: PackageConfig -> PackageId
 packageConfigId = mkPackageId . package
 
--- | Try and interpret a GHC 'PackageId' as a cabal 'PackageIdentifer'. Returns @Nothing@ if
--- we could not parse it as such an object.
-unpackPackageId :: PackageId -> Maybe PackageIdentifier
-unpackPackageId p
-  = case [ pid | (pid,"") <- readP_to_S parse str ] of
-        []      -> Nothing
-        (pid:_) -> Just pid
-  where str = packageIdString p
-
 -- | Turn a 'PackageConfig', which contains GHC 'Module.ModuleName's into a Cabal specific
 -- 'InstalledPackageInfo' which contains Cabal 'Distribution.ModuleName.ModuleName's
 packageConfigToInstalledPackageInfo :: PackageConfig -> InstalledPackageInfo
diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs
index 7cb3337267..38a1f9dce8 100644
--- a/compiler/main/Packages.lhs
+++ b/compiler/main/Packages.lhs
@@ -42,15 +42,16 @@ import StaticFlags
 import Config		( cProjectVersion )
 import Name		( Name, nameModule_maybe )
 import UniqFM
+import FiniteMap
 import Module
 import Util
-import Maybes		( expectJust, MaybeErr(..) )
 import Panic
 import Outputable
+import Maybes
 
 import System.Environment ( getEnv )
-import Distribution.InstalledPackageInfo hiding (depends)
-import Distribution.Package hiding (depends, PackageId)
+import Distribution.InstalledPackageInfo
+import Distribution.Package hiding (PackageId,depends)
 import FastString
 import ErrUtils         ( debugTraceMsg, putMsg, Message )
 import Exception
@@ -59,7 +60,7 @@ import System.Directory
 import System.FilePath
 import Data.Maybe
 import Control.Monad
-import Data.List
+import Data.List as List
 
 -- ---------------------------------------------------------------------------
 -- The Package state
@@ -113,11 +114,13 @@ data PackageState = PackageState {
 	-- should be in reverse dependency order; that is, a package
 	-- is always mentioned before the packages it depends on.
 
-  moduleToPkgConfAll 	:: UniqFM [(PackageConfig,Bool)] -- ModuleEnv mapping
+  moduleToPkgConfAll 	:: UniqFM [(PackageConfig,Bool)], -- ModuleEnv mapping
 	-- Derived from pkgIdMap.	
 	-- Maps Module to (pkgconf,exposed), where pkgconf is the
 	-- PackageConfig for the package containing the module, and
 	-- exposed is True if the package exposes that module.
+
+  installedPackageIdMap :: FiniteMap InstalledPackageId PackageId
   }
 
 -- | A PackageConfigMap maps a 'PackageId' to a 'PackageConfig'
@@ -370,32 +373,27 @@ hideOldPackages dflags pkgs = mapM maybe_hide pkgs
 findWiredInPackages
    :: DynFlags
    -> [PackageConfig]           -- database
-   -> [PackageIdentifier]       -- preload packages
-   -> PackageId 		-- this package
-   -> IO ([PackageConfig],
-          [PackageIdentifier],
-          PackageId)
+   -> IO [PackageConfig]
 
-findWiredInPackages dflags pkgs preload this_package = do
+findWiredInPackages dflags pkgs = do
   --
   -- Now we must find our wired-in packages, and rename them to
   -- their canonical names (eg. base-1.0 ==> base).
   --
   let
-        wired_in_pkgids :: [(PackageId, [String])]
-        wired_in_pkgids = [ (primPackageId, [""]),
-                            (integerPackageId, [""]),
-                            (basePackageId, [""]),
-                            (rtsPackageId, [""]),
-                            (haskell98PackageId, [""]),
-                            (thPackageId, [""]),
-                            (dphSeqPackageId, [""]),
-                            (dphParPackageId, [""])]
-
-        matches :: PackageConfig -> (PackageId, [String]) -> Bool
-        pc `matches` (pid, suffixes)
-            = display (pkgName (package pc)) `elem`
-              (map (packageIdString pid ++) suffixes)
+        wired_in_pkgids :: [String]
+        wired_in_pkgids = map packageIdString
+                          [ primPackageId,
+                            integerPackageId,
+                            basePackageId,
+                            rtsPackageId,
+                            haskell98PackageId,
+                            thPackageId,
+                            dphSeqPackageId,
+                            dphParPackageId ]
+
+        matches :: PackageConfig -> String -> Bool
+        pc `matches` pid = display (pkgName (package pc)) == pid
 
 	-- find which package corresponds to each wired-in package
 	-- delete any other packages with the same name
@@ -407,33 +405,29 @@ findWiredInPackages dflags pkgs preload this_package = do
         -- version.  To override the default choice, -hide-package
         -- could be used to hide newer versions.
         --
-	findWiredInPackage :: [PackageConfig] -> (PackageId, [String])
-			   -> IO (Maybe (PackageIdentifier, PackageId))
+	findWiredInPackage :: [PackageConfig] -> String
+			   -> IO (Maybe InstalledPackageId)
 	findWiredInPackage pkgs wired_pkg =
            let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] in
 	   case all_ps of
 		[]   -> notfound
 		many -> pick (head (sortByVersion many))
           where
-                suffixes = snd wired_pkg
                 notfound = do
 			  debugTraceMsg dflags 2 $
 			    ptext (sLit "wired-in package ")
-				 <> ppr (fst wired_pkg)
-                                 <> (if null suffixes
-                                     then empty
-                                     else text (show suffixes))
+				 <> text wired_pkg
 				 <> ptext (sLit " not found.")
 			  return Nothing
 		pick :: InstalledPackageInfo_ ModuleName
-                     -> IO (Maybe (PackageIdentifier, PackageId))
+                     -> IO (Maybe InstalledPackageId)
                 pick pkg = do
                         debugTraceMsg dflags 2 $
 			    ptext (sLit "wired-in package ")
-				 <> ppr (fst wired_pkg)
+				 <> text wired_pkg
 				 <> ptext (sLit " mapped to ")
 				 <> text (display (package pkg))
-			return (Just (package pkg, fst wired_pkg))
+			return (Just (installedPackageId pkg))
 
 
   mb_wired_in_ids <- mapM (findWiredInPackage pkgs) wired_in_pkgids
@@ -454,26 +448,13 @@ findWiredInPackages dflags pkgs preload this_package = do
         -}
 
 	updateWiredInDependencies pkgs = map upd_pkg pkgs
-	  where upd_pkg p = p{ package = upd_pid (package p),
-			       depends = map upd_pid (depends p) }
-
-	upd_pid pid = case filter ((== pid) . fst) wired_in_ids of
-				[] -> pid
-				((x, y):_) -> x{ pkgName = PackageName (packageIdString y),
-                                                 pkgVersion = Version [] [] }
-
-        -- pkgs1 = deleteOtherWiredInPackages pkgs
-
-        pkgs2 = updateWiredInDependencies pkgs
-
-        preload1 = map upd_pid preload
+	  where upd_pkg p
+                  | installedPackageId p `elem` wired_in_ids
+                  = p { package = (package p){ pkgVersion = Version [] [] } }
+                  | otherwise
+                  = p
 
-        -- we must return an updated thisPackage, just in case we
-        -- are actually compiling one of the wired-in packages
-        Just old_this_pkg = unpackPackageId this_package
-        new_this_pkg = mkPackageId (upd_pid old_this_pkg)
-
-  return (pkgs2, preload1, new_this_pkg)
+  return $ updateWiredInDependencies pkgs
 
 -- ----------------------------------------------------------------------------
 --
@@ -499,12 +480,12 @@ elimDanglingDeps dflags pkgs ignored = go [] pkgs'
         (new_avail, not_avail) -> go (new_avail ++ avail) (map fst not_avail)
 
    depsAvailable :: [PackageConfig] -> PackageConfig
-                 -> Either PackageConfig (PackageConfig, [PackageIdentifier])
+                 -> Either PackageConfig (PackageConfig, [InstalledPackageId])
    depsAvailable pkgs_ok pkg 
         | null dangling = Left pkg
         | otherwise     = Right (pkg, dangling)
         where dangling = filter (`notElem` pids) (depends pkg)
-              pids = map package pkgs_ok
+              pids = map installedPackageId pkgs_ok
 
    reportElim (p, deps) = 
         debugTraceMsg dflags 2 $
@@ -542,15 +523,14 @@ mkPackageState dflags orig_pkg_db preload0 this_package = do
   -- should contain at least rts & base, which is why we pretend that
   -- the command line contains -package rts & -package base.
   --
-  let new_preload_packages = 
-        map package (pickPackages pkgs0 [ p | ExposePackage p <- flags ])
+  let preload1 = map installedPackageId $ 
+                 pickPackages pkgs0 [ p | ExposePackage p <- flags ]
 
   -- hide packages that are subsumed by later versions
   pkgs2 <- hideOldPackages dflags pkgs1
 
   -- sort out which packages are wired in
-  (pkgs3, preload1, new_this_pkg)
-        <- findWiredInPackages dflags pkgs2 new_preload_packages this_package
+  pkgs3 <- findWiredInPackages dflags pkgs2
 
   let ignored = map packageConfigId $
                    pickPackages pkgs0 [ p | IgnorePackage p <- flags ]
@@ -558,6 +538,16 @@ mkPackageState dflags orig_pkg_db preload0 this_package = do
 
   let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs
 
+      ipid_map = listToFM [ (installedPackageId p, packageConfigId p)
+                          | p <- pkgs ]
+
+      lookupIPID ipid@(InstalledPackageId str)
+         | Just pid <- lookupFM ipid_map ipid = return pid
+         | otherwise                          = missingPackageErr str
+
+  preload2 <- mapM lookupIPID preload1
+
+  let
       -- add base & rts to the preload packages
       basicLinkedPackages
        | dopt Opt_AutoLinkPackages dflags
@@ -566,19 +556,20 @@ mkPackageState dflags orig_pkg_db preload0 this_package = do
       -- but in any case remove the current package from the set of
       -- preloaded packages so that base/rts does not end up in the
       -- set up preloaded package when we are just building it
-      preload2 = nub (filter (/= new_this_pkg)
-		             (basicLinkedPackages ++ map mkPackageId preload1))
+      preload3 = nub $ filter (/= this_package)
+                     $ (basicLinkedPackages ++ preload2)
 
   -- Close the preload packages with their dependencies
-  dep_preload <- closeDeps pkg_db (zip preload2 (repeat Nothing))
+  dep_preload <- closeDeps pkg_db ipid_map (zip preload3 (repeat Nothing))
   let new_dep_preload = filter (`notElem` preload0) dep_preload
 
   let pstate = PackageState{ preloadPackages     = dep_preload,
 		             pkgIdMap   	 = pkg_db,
-		             moduleToPkgConfAll  = mkModuleMap pkg_db
+		             moduleToPkgConfAll  = mkModuleMap pkg_db,
+                             installedPackageIdMap = ipid_map
 		           }
 
-  return (pstate, new_dep_preload, new_this_pkg)
+  return (pstate, new_dep_preload, this_package)
 
 
 -- -----------------------------------------------------------------------------
@@ -697,31 +688,39 @@ getPreloadPackagesAnd dflags pkgids =
   let 
       state   = pkgState dflags
       pkg_map = pkgIdMap state
+      ipid_map = installedPackageIdMap state
       preload = preloadPackages state
       pairs = zip pkgids (repeat Nothing)
   in do
-  all_pkgs <- throwErr (foldM (add_package pkg_map) preload pairs)
+  all_pkgs <- throwErr (foldM (add_package pkg_map ipid_map) preload pairs)
   return (map (getPackageDetails state) all_pkgs)
 
 -- Takes a list of packages, and returns the list with dependencies included,
 -- in reverse dependency order (a package appears before those it depends on).
-closeDeps :: PackageConfigMap -> [(PackageId, Maybe PackageId)]
-        -> IO [PackageId]
-closeDeps pkg_map ps = throwErr (closeDepsErr pkg_map ps)
+closeDeps :: PackageConfigMap
+          -> FiniteMap InstalledPackageId PackageId
+          -> [(PackageId, Maybe PackageId)]
+          -> IO [PackageId]
+closeDeps pkg_map ipid_map ps = throwErr (closeDepsErr pkg_map ipid_map ps)
 
 throwErr :: MaybeErr Message a -> IO a
 throwErr m = case m of
 		Failed e    -> ghcError (CmdLineError (showSDoc e))
 		Succeeded r -> return r
 
-closeDepsErr :: PackageConfigMap -> [(PackageId,Maybe PackageId)]
-	-> MaybeErr Message [PackageId]
-closeDepsErr pkg_map ps = foldM (add_package pkg_map) [] ps
+closeDepsErr :: PackageConfigMap
+             -> FiniteMap InstalledPackageId PackageId
+             -> [(PackageId,Maybe PackageId)]
+             -> MaybeErr Message [PackageId]
+closeDepsErr pkg_map ipid_map ps = foldM (add_package pkg_map ipid_map) [] ps
 
 -- internal helper
-add_package :: PackageConfigMap -> [PackageId] -> (PackageId,Maybe PackageId)
-	-> MaybeErr Message [PackageId]
-add_package pkg_db ps (p, mb_parent)
+add_package :: PackageConfigMap 
+            -> FiniteMap InstalledPackageId PackageId
+            -> [PackageId]
+            -> (PackageId,Maybe PackageId)
+            -> MaybeErr Message [PackageId]
+add_package pkg_db ipid_map ps (p, mb_parent)
   | p `elem` ps = return ps	-- Check if we've already added this package
   | otherwise =
       case lookupPackage pkg_db p of
@@ -729,11 +728,16 @@ add_package pkg_db ps (p, mb_parent)
                            missingDependencyMsg mb_parent)
         Just pkg -> do
     	   -- Add the package's dependents also
-	   let deps = map mkPackageId (depends pkg)
-    	   ps' <- foldM (add_package pkg_db) ps (zip deps (repeat (Just p)))
+    	   ps' <- foldM add_package_ipid ps (depends pkg)
     	   return (p : ps')
+          where
+            add_package_ipid ps ipid@(InstalledPackageId str)
+              | Just pid <- lookupFM ipid_map ipid
+              = add_package pkg_db ipid_map ps (pid, Just p)
+              | otherwise
+              = Failed (missingPackageMsg str <> missingDependencyMsg mb_parent)
 
-missingPackageErr :: String -> IO [PackageConfig]
+missingPackageErr :: String -> IO a
 missingPackageErr p = ghcError (CmdLineError (showSDoc (missingPackageMsg p)))
 
 missingPackageMsg :: String -> SDoc
diff --git a/compiler/main/ParsePkgConf.y b/compiler/main/ParsePkgConf.y
index 6028af89ce..d05a6d54c0 100644
--- a/compiler/main/ParsePkgConf.y
+++ b/compiler/main/ParsePkgConf.y
@@ -81,8 +81,12 @@ field	:: { PackageConfig -> PackageConfig }
 		   	_         -> happyError }
 		}
 
-	| VARID '=' CONID STRING	{ id }
-		-- another case of license
+	| VARID '=' CONID STRING
+		{ \p -> case unpackFS $1 of
+                          "installedPackageId" ->
+                              p{installedPackageId = InstalledPackageId (unpackFS $4)}
+			  _ -> p -- another case of license
+		}
 
 	| VARID '=' strlist		
 	{\p -> case unpackFS $1 of
@@ -107,7 +111,7 @@ field	:: { PackageConfig -> PackageConfig }
 		_ -> p
 	}
 
-	| VARID '=' pkgidlist
+	| VARID '=' ipidlist
 		{% case unpackFS $1 of
 		        "depends"     -> return (\p -> p{depends = $3})
 			_             -> happyError
@@ -129,13 +133,20 @@ version :: { Version }
 			{ Version{ versionBranch=$5, 
                                    versionTags=map unpackFS $9 } }
 
-pkgidlist :: { [PackageIdentifier] }
-	: '[' pkgids ']'		{ $2 }
+ipid    :: { InstalledPackageId }
+        : CONID STRING
+            {% case unpackFS $1 of
+               "InstalledPackageId" -> return (InstalledPackageId (unpackFS $2))
+               _ -> happyError
+            }
+
+ipidlist :: { [InstalledPackageId] }
+	: '[' ipids ']'		{ $2 }
 	-- empty list case is covered by strlist, to avoid conflicts
 
-pkgids	:: { [PackageIdentifier] }
-	: pkgid				{ [ $1 ] }
-	| pkgid ',' pkgids		{ $1 : $3 }
+ipids	:: { [InstalledPackageId] }
+	: ipid				{ [ $1 ] }
+	| ipid ',' ipids                { $1 : $3 }
 
 intlist :: { [Int] }
         : '[' ']'			{ [] }
diff --git a/libffi/package.conf.in b/libffi/package.conf.in
index eea9c401d5..649540f55b 100644
--- a/libffi/package.conf.in
+++ b/libffi/package.conf.in
@@ -1,5 +1,6 @@
 name:		ffi
 version:	1.0
+id:             builtin:ffi
 license:	BSD3
 maintainer:	glasgow-haskell-users@haskell.org
 exposed:	True
diff --git a/rts/package.conf.in b/rts/package.conf.in
index 32bd00fb89..1112b99d5f 100644
--- a/rts/package.conf.in
+++ b/rts/package.conf.in
@@ -5,6 +5,7 @@
 
 name:		rts
 version:	1.0
+id:             builtin:rts
 license:	BSD3
 maintainer:	glasgow-haskell-users@haskell.org
 exposed:	True
@@ -55,7 +56,7 @@ include-dirs:		TOP"/includes"
 #endif
 
 includes:		Stg.h
-depends:	 	ffi-1.0
+depends:	 	builtin:ffi
 hugs-options:
 cc-options:
 
diff --git a/utils/ghc-cabal/ghc-cabal.hs b/utils/ghc-cabal/ghc-cabal.hs
index 8c9612f0ff..8ee1304fb8 100644
--- a/utils/ghc-cabal/ghc-cabal.hs
+++ b/utils/ghc-cabal/ghc-cabal.hs
@@ -25,6 +25,7 @@ import System.Directory
 import System.Environment
 import System.Exit
 import System.FilePath
+import Data.Char
 
 main :: IO ()
 main = do args <- getArgs
@@ -208,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?"
 
@@ -242,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),
diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index f79ebab677..a13ba44644 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -1,26 +1,21 @@
 {-# OPTIONS -fglasgow-exts -cpp #-}
 -----------------------------------------------------------------------------
 --
--- (c) The University of Glasgow 2004.
+-- (c) The University of Glasgow 2004-2009.
 --
 -- Package management tool
 --
 -----------------------------------------------------------------------------
 
--- TODO:
--- * validate modules
--- * expanding of variables in new-style package conf
--- * version manipulation (checking whether old version exists,
---   hiding old version?)
-
 module Main (main) where
 
 import Version ( version, targetOS, targetARCH )
+import qualified Distribution.Simple.PackageIndex as PackageIndex
 import Distribution.ModuleName hiding (main)
-import Distribution.InstalledPackageInfo hiding (depends)
+import Distribution.InstalledPackageInfo
 import Distribution.Compat.ReadP
 import Distribution.ParseUtils
-import Distribution.Package
+import Distribution.Package hiding (depends)
 import Distribution.Text
 import Distribution.Version
 import System.FilePath
@@ -192,6 +187,11 @@ usageHeader prog = substProg prog $
   "    all the registered versions will be listed in ascending order.\n" ++
   "    Accepts the --simple-output flag.\n" ++
   "\n" ++
+  "  $p dot\n" ++
+  "    Generate a graph of the package dependencies in a form suitable\n" ++
+  "    for input for the graphviz tools.  For example, to generate a PDF" ++
+  "    of the dependency graph: ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf" ++
+  "\n" ++
   "  $p find-module {module}\n" ++
   "    List registered packages exposing module {module} in the global\n" ++
   "    database, and also the user database if --user is given.\n" ++
@@ -230,7 +230,7 @@ usageHeader prog = substProg prog $
   "  entirely. When multiple of these options are given, the rightmost\n"++
   "  one is used as the database to act upon.\n"++
   "\n"++
-  "  Commands that query the package database (list, latest, describe,\n"++
+  "  Commands that query the package database (list, tree, latest, describe,\n"++
   "  field) operate on the list of databases specified by the flags\n"++
   "  --user, --global, and --package-conf.  If none of these flags are\n"++
   "  given, the default is --global --user.\n"++
@@ -310,15 +310,17 @@ runit verbosity cli nonopts = do
         pkgid <- readGlobPkgId pkgid_str
         hidePackage pkgid verbosity cli force
     ["list"] -> do
-        listPackages cli Nothing Nothing
+        listPackages verbosity cli Nothing Nothing
     ["list", pkgid_str] ->
         case substringCheck pkgid_str of
           Nothing -> do pkgid <- readGlobPkgId pkgid_str
-                        listPackages cli (Just (Id pkgid)) Nothing
-          Just m -> listPackages cli (Just (Substring pkgid_str m)) Nothing
+                        listPackages verbosity cli (Just (Id pkgid)) Nothing
+          Just m -> listPackages verbosity cli (Just (Substring pkgid_str m)) Nothing
+    ["dot"] -> do
+        showPackageDot verbosity cli
     ["find-module", moduleName] -> do
         let match = maybe (==moduleName) id (substringCheck moduleName)
-        listPackages cli Nothing (Just match)
+        listPackages verbosity cli Nothing (Just match)
     ["latest", pkgid_str] -> do
         pkgid <- readGlobPkgId pkgid_str
         latestPackage cli pkgid
@@ -544,11 +546,6 @@ registerPackage input verbosity my_flags auto_ghci_libs update force = do
   when (verbosity >= Normal) $
       putStrLn "done."
 
-  let unversioned_deps = filter (not . realVersion) (depends pkg)
-  unless (null unversioned_deps) $
-      die ("Unversioned dependencies found: " ++
-           unwords (map display unversioned_deps))
-
   let truncated_stack = dropWhile ((/= to_modify).fst) db_stack
   -- truncate the stack for validation, because we don't allow
   -- packages lower in the stack to refer to those higher up.
@@ -616,8 +613,10 @@ modifyPackage fn pkgid verbosity my_flags force = do
 -- -----------------------------------------------------------------------------
 -- Listing packages
 
-listPackages ::  [Flag] -> Maybe PackageArg -> Maybe (String->Bool) -> IO ()
-listPackages my_flags mPackageName mModuleName = do
+listPackages ::  Verbosity -> [Flag] -> Maybe PackageArg
+             -> Maybe (String->Bool)
+             -> IO ()
+listPackages verbosity my_flags mPackageName mModuleName = do
   let simple_output = FlagSimpleOutput `elem` my_flags
   (db_stack, _) <- getPkgDatabases False my_flags
   let db_stack_filtered -- if a package is given, filter out all other packages
@@ -642,23 +641,35 @@ listPackages my_flags mPackageName mModuleName = do
       match `exposedInPkg` pkg = any match (map display $ exposedModules pkg)
 
       pkg_map = allPackagesInStack db_stack
-      show_func = if simple_output then show_simple else mapM_ (show_normal pkg_map)
+      broken = map package (brokenPackages pkg_map)
 
-  show_func (reverse db_stack_sorted)
+      show_func = if simple_output then show_simple else mapM_ show_normal
 
-  where show_normal pkg_map (db_name,pkg_confs) =
+      show_normal (db_name,pkg_confs) =
           hPutStrLn stdout (render $
                 text db_name <> colon $$ nest 4 packages
                 )
-           where packages = fsep (punctuate comma (map pp_pkg pkg_confs))
-                 broken = map package (brokenPackages pkg_map)
+           where packages
+                    | verbosity >= Verbose = vcat (map pp_pkg pkg_confs)
+                    | otherwise = fsep (punctuate comma (map pp_pkg pkg_confs))
                  pp_pkg p
                    | package p `elem` broken = braces doc
                    | exposed p = doc
                    | otherwise = parens doc
-                   where doc = text (display (package p))
+                   where doc | verbosity >= Verbose = pkg <+> parens ipid
+                             | otherwise            = pkg
+                          where
+                          InstalledPackageId ipid_str = installedPackageId p
+                          ipid = text ipid_str
+                          pkg = text (display (package p))
+
+      show_simple = simplePackageList my_flags . allPackagesInStack
 
-        show_simple = simplePackageList my_flags . allPackagesInStack
+  when (not (null broken) && verbosity /= Silent) $ do
+     prog <- getProgramName
+     putStrLn ("WARNING: there are broken packages.  Run '" ++ prog ++ " check' for more details.")
+
+  show_func (reverse db_stack_sorted)
 
 simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
 simplePackageList my_flags pkgs = do
@@ -668,6 +679,23 @@ simplePackageList my_flags pkgs = do
    when (not (null pkgs)) $
       hPutStrLn stdout $ concat $ intersperse " " strs
 
+showPackageDot :: Verbosity -> [Flag] -> IO ()
+showPackageDot _verbosity myflags = do
+  (db_stack, _) <- getPkgDatabases False myflags
+  let all_pkgs = allPackagesInStack db_stack
+      ipix  = PackageIndex.listToInstalledPackageIndex all_pkgs
+
+  putStrLn "digraph {"
+  let quote s = '"':s ++ "\""
+  mapM_ putStrLn [ quote from ++ " -> " ++ quote to
+                 | p <- all_pkgs,
+                   let from = display (package p),
+                   depid <- depends p,
+                   Just dep <- [PackageIndex.lookupInstalledPackage ipix depid],
+                   let to = display (package dep)
+                 ]
+  putStrLn "}"
+
 -- -----------------------------------------------------------------------------
 -- Prints the highest (hidden or exposed) version of a package
 
@@ -720,6 +748,10 @@ pid `matches` pid'
   = (pkgName pid == pkgName pid')
     && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
 
+realVersion :: PackageIdentifier -> Bool
+realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
+  -- when versionBranch == [], this is a glob
+
 matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
 (Id pid)        `matchesPkg` pkg = pid `matches` package pkg
 (Substring _ m) `matchesPkg` pkg = m (display (package pkg))
@@ -851,7 +883,7 @@ closure pkgs db_stack = go pkgs db_stack
                  -> Bool
    depsAvailable pkgs_ok pkg = null dangling
         where dangling = filter (`notElem` pids) (depends pkg)
-              pids = map package pkgs_ok
+              pids = map installedPackageId pkgs_ok
 
         -- we want mutually recursive groups of package to show up
         -- as broken. (#1750)
@@ -954,6 +986,7 @@ checkPackageConfig :: InstalledPackageInfo
                       -> Bool   -- update, or check
                       -> Validate ()
 checkPackageConfig pkg db_stack auto_ghci_libs update = do
+  checkInstalledPackageId pkg db_stack update
   checkPackageId pkg
   checkDuplicates db_stack pkg update
   mapM_ (checkDep db_stack) (depends pkg)
@@ -967,6 +1000,18 @@ checkPackageConfig pkg db_stack auto_ghci_libs update = do
   --    extra_libraries :: [String],
   --    c_includes      :: [String],
 
+checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool 
+                        -> Validate ()
+checkInstalledPackageId ipi db_stack update = do
+  let ipid@(InstalledPackageId str) = installedPackageId ipi
+  when (null str) $ verror CannotForce "missing id field"
+  let dups = [ p | p <- allPackagesInStack db_stack, 
+                   installedPackageId p == ipid ]
+  when (not update && not (null dups)) $
+    verror CannotForce $
+        "package(s) with this id already exist: " ++ 
+         unwords (map (display.packageId) dups)
+
 -- When the package name and version are put together, sometimes we can
 -- end up with a package id that cannot be parsed.  This will lead to
 -- difficulties when the user wants to refer to the package later, so
@@ -1011,23 +1056,16 @@ checkDir thisfield d
    when (not there) $
        verror ForceFiles (thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory")
 
-checkDep :: PackageDBStack -> PackageIdentifier -> Validate ()
+checkDep :: PackageDBStack -> InstalledPackageId -> Validate ()
 checkDep db_stack pkgid
-  | pkgid `elem` pkgids || (not real_version && name_exists) = return ()
-  | otherwise = verror ForceAll ("dependency " ++ display pkgid
-                                 ++ " doesn't exist")
+  | pkgid `elem` pkgids = return ()
+  | otherwise = verror ForceAll ("dependency \"" ++ display pkgid
+                                 ++ "\" doesn't exist")
   where
-        -- for backwards compat, we treat 0.0 as a special version,
-        -- and don't check that it actually exists.
-        real_version = realVersion pkgid
-
-        name_exists = any (\p -> pkgName (package p) == name) all_pkgs
-        name = pkgName pkgid
-
         all_pkgs = allPackagesInStack db_stack
-        pkgids = map package all_pkgs
+        pkgids = map installedPackageId all_pkgs
 
-checkDuplicateDepends :: [PackageIdentifier] -> Validate ()
+checkDuplicateDepends :: [InstalledPackageId] -> Validate ()
 checkDuplicateDepends deps
   | null dups = return ()
   | otherwise = verror ForceAll ("package has duplicate dependencies: " ++
@@ -1035,9 +1073,6 @@ checkDuplicateDepends deps
   where
        dups = [ p | (p:_:_) <- group (sort deps) ]
 
-realVersion :: PackageIdentifier -> Bool
-realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
-
 checkHSLib :: [String] -> Bool -> String -> Validate ()
 checkHSLib dirs auto_ghci_libs lib = do
   let batch_lib_file = "lib" ++ lib ++ ".a"