X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Futils%2Fghc-pkg%2FMain.hs;h=fb3ef07c3ffadfda6a767fe50e2a409089a0f8b9;hb=50bc39808cd5b483a048a4d387f937963bd0e00f;hp=04170c4c4362796a1d0c461d8a7b055c8420c218;hpb=080a6a8a80f9d718482681e83d22ecf79a0a5688;p=ghc-hetmet.git

diff --git a/ghc/utils/ghc-pkg/Main.hs b/ghc/utils/ghc-pkg/Main.hs
index 04170c4..fb3ef07 100644
--- a/ghc/utils/ghc-pkg/Main.hs
+++ b/ghc/utils/ghc-pkg/Main.hs
@@ -290,6 +290,16 @@ getPkgDatabases modify flags = do
 			Just dir -> return (dir `joinFileName` "package.conf")
         fs -> return (last fs)
 
+  let global_conf_dir = global_conf ++ ".d"
+  global_conf_dir_exists <- doesDirectoryExist global_conf_dir
+  global_confs <-
+    if global_conf_dir_exists
+      then do files <- getDirectoryContents global_conf_dir
+              return [ global_conf_dir ++ '/' : file
+                     | file <- files
+                     , isSuffixOf ".conf" file]
+      else return []
+
   -- get the location of the user package database, and create it if necessary
   appdir <- getAppUserDataDirectory "ghc"
 
@@ -302,8 +312,8 @@ getPkgDatabases modify flags = do
   -- If the user database doesn't exist, and this command isn't a
   -- "modify" command, then we won't attempt to create or use it.
   let sys_databases
-	| modify || user_exists = [user_conf,global_conf]
-	| otherwise             = [global_conf]
+	| modify || user_exists = user_conf : global_confs ++ [global_conf]
+	| otherwise             = global_confs ++ [global_conf]
 
   e_pkg_path <- try (getEnv "GHC_PACKAGE_PATH")
   let env_stack =
@@ -314,6 +324,10 @@ getPkgDatabases modify flags = do
 		  | otherwise      -> cs
 		  where cs = parseSearchPath path
 
+	-- The "global" database is always the one at the bottom of the stack.
+	-- This is the database we modify by default.
+      virt_global_conf = last env_stack
+
   -- -f flags on the command line add to the database stack, unless any
   -- of them are present in the stack already.
   let flag_stack = filter (`notElem` env_stack) 
@@ -327,10 +341,10 @@ getPkgDatabases modify flags = do
         then return flag_stack
 	else let
 	      	go (FlagUser : fs)     = modifying user_conf
-	      	go (FlagGlobal : fs)   = modifying global_conf
+	      	go (FlagGlobal : fs)   = modifying virt_global_conf
 	      	go (FlagConfig f : fs) = modifying f
 	      	go (_ : fs)            = go fs
-	      	go []                  = modifying global_conf
+	      	go []                  = modifying virt_global_conf
 		
 		modifying f 
 		  | f `elem` flag_stack = return (dropWhile (/= f) flag_stack)
@@ -406,7 +420,7 @@ parsePackageInfo
 	-> IO InstalledPackageInfo
 parsePackageInfo str defines force =
   case parseInstalledPackageInfo str of
-    ParseOk ok -> return ok
+    ParseOk _warns ok -> return ok
     ParseFailed err -> die (showError err)
 
 -- -----------------------------------------------------------------------------
@@ -452,8 +466,21 @@ listPackages flags mPackageName = do
             map (\(conf,pkgs) -> (conf, filter (this `matchesPkg`) pkgs)) 
 		db_stack
         | otherwise = db_stack
+
+      db_stack_sorted 
+          = [ (db, sort_pkgs pkgs) | (db,pkgs) <- db_stack_filtered ]
+	  where sort_pkgs = sortBy cmpPkgIds
+		cmpPkgIds pkg1 pkg2 = 
+		   case pkgName p1 `compare` pkgName p2 of
+			LT -> LT
+			GT -> GT
+			EQ -> pkgVersion p1 `compare` pkgVersion p2
+		   where (p1,p2) = (package pkg1, package pkg2)
+
       show_func = if simple_output then show_easy else mapM_ show_regular
-  show_func (reverse db_stack_filtered)
+
+  show_func (reverse db_stack_sorted)
+
   where show_regular (db_name,pkg_confs) =
 	  hPutStrLn stdout (render $
 		text (db_name ++ ":") $$ nest 4 packages
@@ -463,6 +490,7 @@ listPackages flags mPackageName = do
 		   | exposed p = doc
 		   | otherwise = parens doc
 		   where doc = text (showPackageId (package p))
+
         show_easy db_stack = do
           let pkgs = map showPackageId $ sortBy compPkgIdVer $
                           map package (concatMap snd db_stack)