[project @ 2005-03-16 10:18:28 by simonmar]

[ghc-hetmet.git] / ghc / utils / ghc-pkg / Main.hs

diff --git a/ghc/utils/ghc-pkg/Main.hs b/ghc/utils/ghc-pkg/Main.hs
index 1c97030..42753db 100644 (file)
--- a/ghc/utils/ghc-pkg/Main.hs
+++ b/ghc/utils/ghc-pkg/Main.hs
@@ -18,12 +18,11 @@ module Main (main) where
 import Version ( version, targetOS, targetARCH )
 import Distribution.InstalledPackageInfo
 import Distribution.Compat.ReadP
-import Distribution.ParseUtils ( showError, ParseResult(..) )
+import Distribution.ParseUtils ( showError )
 import Distribution.Package
 import Distribution.Version
 import Compat.Directory        ( getAppUserDataDirectory, createDirectoryIfMissing )
 import Compat.RawSystem        ( rawSystem )
-import Control.Exception       ( evaluate )
 
 import Prelude
 
@@ -225,6 +224,7 @@ parseGlobPackageId =
       return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
 
 -- globVersion means "all versions"
+globVersion :: Version
 globVersion = Version{ versionBranch=[], versionTags=["*"] }
 
 -- -----------------------------------------------------------------------------
@@ -268,11 +268,7 @@ getPkgDatabases modify flags = do
        subdir = targetARCH ++ '-':targetOS ++ '-':version
        archdir   = appdir `joinFileName` subdir
        user_conf = archdir `joinFileName` "package.conf"
-  b <- doesFileExist user_conf
-  when (not b) $ do
-       putStrLn ("Creating user package database in " ++ user_conf)
-       createDirectoryIfMissing True archdir
-       writeFile user_conf emptyPackageConfig
+  user_exists <- doesFileExist user_conf
 
   let
        -- The semantics here are slightly strange.  If we are
@@ -281,8 +277,9 @@ getPkgDatabases modify flags = do
        -- If we are not modifying (eg. list, describe etc.) then
        -- the user database is included by default.
        databases
-         | modify     = foldl addDB [global_conf] flags
-         | not modify = foldl addDB [user_conf,global_conf] flags
+         | modify          = foldl addDB [global_conf] flags
+         | not user_exists = foldl addDB [global_conf] flags
+         | otherwise       = foldl addDB [user_conf,global_conf] flags
 
        -- implement the following rules:
        --      --user means overlap with the user database
@@ -295,6 +292,11 @@ getPkgDatabases modify flags = do
        addDB dbs (FlagConfig f) = f : dbs
        addDB dbs _              = dbs
 
+  when (not user_exists && user_conf `elem` databases) $ do
+       putStrLn ("Creating user package database in " ++ user_conf)
+       createDirectoryIfMissing True archdir
+       writeFile user_conf emptyPackageConfig
+
   db_stack <- mapM readParseDatabase databases
   return db_stack
 
@@ -302,7 +304,7 @@ readParseDatabase :: PackageDBName -> IO (PackageDBName,PackageDB)
 readParseDatabase filename = do
   str <- readFile filename
   let packages = read str
-  evaluate packages
+  Exception.evaluate packages
     `Exception.catch` \_ -> 
        die (filename ++ ": parse error in package config file")
   return (filename,packages)
@@ -834,6 +836,7 @@ oldRunit clis = do
        prog <- getProgramName
        die (usageInfo (usageHeader prog) flags)
 
+my_head :: String -> [a] -> a
 my_head s [] = error s
 my_head s (x:xs) = x