Add unique package identifiers (InstalledPackageId) in the package DB

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

6 files changed, 116 insertions, 113 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] }
         : '[' ']'			{ [] }