From: simonmar Date: Fri, 4 Nov 2005 15:48:26 +0000 (+0000) Subject: [project @ 2005-11-04 15:48:25 by simonmar] X-Git-Tag: Initial_conversion_from_CVS_complete~67 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=be8b6cd519e181e2553ee48ef4a82b8d56a4e9b6;p=ghc-hetmet.git [project @ 2005-11-04 15:48:25 by simonmar] - Add support for the GHC_PACKAGE_PATH environment variable, which specifies a :-separated (;-separated on Windows) list of package database files. If the list ends in : (; on Windows), then the normal user and global databases are added. GHC_PACKAGE_PATH is searched left-to-right for packages, like $PATH, but unlike -package-conf flags, which are searched right-to-left. This isn't ideal, but it seemed the least worst to me (command line flags always override right-to-left (except -i), whereas the PATH environment variable overrides left-to-right, I chose to follow the environment variable convention). I can always change it if there's an outcry. - Rationalise the interpretation of --user, --global, and -f on the ghc-pkg command line. The story is now this: --user and --global say which package database to *act upon*, they do not change the shape of the database stack. -f pushes a database on the stack, and also requests that the specified database be the one to act upon, for commands that modify the database. If a database is already on the stack, then -f just selects it as the one to act upon. This means you can have a bunch of databases in GHC_PACKAGE_PATH, and use -f to select the one to modify. --- diff --git a/ghc/compiler/main/Packages.lhs b/ghc/compiler/main/Packages.lhs index 1ab814b..8324260 100644 --- a/ghc/compiler/main/Packages.lhs +++ b/ghc/compiler/main/Packages.lhs @@ -61,6 +61,7 @@ import System.Directory ( getAppUserDataDirectory ) import Compat.Directory ( getAppUserDataDirectory ) #endif +import System.Environment ( getEnv ) import Distribution.InstalledPackageInfo import Distribution.Package import Distribution.Version @@ -207,33 +208,46 @@ initPackages dflags = do readPackageConfigs :: DynFlags -> IO PackageConfigMap readPackageConfigs dflags = do + e_pkg_path <- try (getEnv "GHC_PACKAGE_PATH") + system_pkgconfs <- getSystemPackageConfigs dflags + + let pkgconfs = case e_pkg_path of + Left _ -> system_pkgconfs + Right path + | last cs == "" -> init cs ++ system_pkgconfs + | otherwise -> cs + where cs = parseSearchPath path + -- if the path ends in a separator (eg. "/foo/bar:") + -- the we tack on the system paths. + + -- Read all the ones mentioned in -package-conf flags + pkg_map <- foldM (readPackageConfig dflags) emptyPackageConfigMap + (reverse pkgconfs ++ extraPkgConfs dflags) + + return pkg_map + + +getSystemPackageConfigs :: DynFlags -> IO [FilePath] +getSystemPackageConfigs dflags = do -- System one always comes first system_pkgconf <- getPackageConfigPath - pkg_map1 <- readPackageConfig dflags emptyPackageConfigMap system_pkgconf -- Read user's package conf (eg. ~/.ghc/i386-linux-6.3/package.conf) -- unless the -no-user-package-conf flag was given. -- We only do this when getAppUserDataDirectory is available -- (GHC >= 6.3). - (exists, pkgconf) <- catch (do + user_pkgconf <- handle (\_ -> return []) $ do appdir <- getAppUserDataDirectory "ghc" let pkgconf = appdir `joinFileName` (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion) `joinFileName` "package.conf" flg <- doesFileExist pkgconf - return (flg, pkgconf)) - -- gobble them all up and turn into False. - (\ _ -> return (False, "")) - pkg_map2 <- if (dopt Opt_ReadUserPackageConf dflags && exists) - then readPackageConfig dflags pkg_map1 pkgconf - else return pkg_map1 - - -- Read all the ones mentioned in -package-conf flags - pkg_map <- foldM (readPackageConfig dflags) pkg_map2 - (extraPkgConfs dflags) + if (flg && dopt Opt_ReadUserPackageConf dflags) + then return [pkgconf] + else return [] - return pkg_map + return (user_pkgconf ++ [system_pkgconf]) readPackageConfig diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs index 0911dba..1598c12 100644 --- a/ghc/compiler/utils/Util.lhs +++ b/ghc/compiler/utils/Util.lhs @@ -70,6 +70,7 @@ module Util ( replaceFilenameSuffix, directoryOf, filenameOf, replaceFilenameDirectory, escapeSpaces, isPathSeparator, + parseSearchPath, normalisePath, platformPath, pgmPath, ) where @@ -950,6 +951,40 @@ isPathSeparator ch = ch == '/' #endif +-------------------------------------------------------------- +-- * Search path +-------------------------------------------------------------- + +-- | The function splits the given string to substrings +-- using the 'searchPathSeparator'. +parseSearchPath :: String -> [FilePath] +parseSearchPath path = split path + where + split :: String -> [String] + split s = + case rest' of + [] -> [chunk] + _:rest -> chunk : split rest + where + chunk = + case chunk' of +#ifdef mingw32_HOST_OS + ('\"':xs@(_:_)) | last xs == '\"' -> init xs +#endif + _ -> chunk' + + (chunk', rest') = break (==searchPathSeparator) s + +-- | A platform-specific character used to separate search path strings in +-- environment variables. The separator is a colon (\":\") on Unix and Macintosh, +-- and a semicolon (\";\") on the Windows operating system. +searchPathSeparator :: Char +#if mingw32_HOST_OS || mingw32_TARGET_OS +searchPathSeparator = ';' +#else +searchPathSeparator = ':' +#endif + ----------------------------------------------------------------------------- -- Convert filepath into platform / MSDOS form. diff --git a/ghc/utils/ghc-pkg/Main.hs b/ghc/utils/ghc-pkg/Main.hs index aacd5ca..e576c9c 100644 --- a/ghc/utils/ghc-pkg/Main.hs +++ b/ghc/utils/ghc-pkg/Main.hs @@ -47,6 +47,7 @@ import System ( getArgs, getProgName, getEnv, exitWith, ExitCode(..) ) import System.IO +import System.IO.Error (try) import Data.List ( isPrefixOf, isSuffixOf, intersperse, groupBy, sortBy ) #ifdef mingw32_HOST_OS @@ -294,36 +295,53 @@ getPkgDatabases modify flags = do user_conf = archdir `joinFileName` "package.conf" user_exists <- doesFileExist user_conf - let - -- The semantics here are slightly strange. If we are - -- *modifying* the database, then the default is to modify - -- the global database by default, unless you say --user. - -- 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 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 - -- --global means reset to just the global database - -- -f means overlap with - addDB dbs FlagUser - | user_conf `elem` dbs = dbs - | modify || user_exists = user_conf : dbs - addDB dbs FlagGlobal = [global_conf] - addDB dbs (FlagConfig f) = f : dbs - addDB dbs _ = dbs + -- 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] + + e_pkg_path <- try (getEnv "GHC_PACKAGE_PATH") + let env_stack = + case e_pkg_path of + Left _ -> sys_databases + Right path + | last cs == "" -> init cs ++ sys_databases + | otherwise -> cs + where cs = parseSearchPath path + + -- -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) + [ f | FlagConfig f <- reverse flags ] ++ env_stack + + -- Now we have the full stack of databases. Next, if the current + -- command is a "modify" type command, then we truncate the stack + -- so that the topmost element is the database being modified. + final_stack <- + if not modify + then return flag_stack + else let + go (FlagUser : fs) = modifying user_conf + go (FlagGlobal : fs) = modifying global_conf + go (FlagConfig f : fs) = modifying f + go (_ : fs) = go fs + go [] = modifying global_conf + + modifying f + | f `elem` flag_stack = return (dropWhile (/= f) flag_stack) + | otherwise = die ("requesting modification of database:\n\t" ++ f ++ "\n\twhich is not in the database stack.") + in + go flags -- we create the user database iff (a) we're modifying, and (b) the -- user asked to use it by giving the --user flag. - when (not user_exists && user_conf `elem` databases) $ do + when (not user_exists && user_conf `elem` final_stack) $ do putStrLn ("Creating user package database in " ++ user_conf) createDirectoryIfMissing True archdir writeFile user_conf emptyPackageConfig - db_stack <- mapM readParseDatabase databases + db_stack <- mapM readParseDatabase final_stack return db_stack readParseDatabase :: PackageDBName -> IO (PackageDBName,PackageDB) @@ -1101,3 +1119,34 @@ pathSeparator = '\\' #else pathSeparator = '/' #endif + +-- | The function splits the given string to substrings +-- using the 'searchPathSeparator'. +parseSearchPath :: String -> [FilePath] +parseSearchPath path = split path + where + split :: String -> [String] + split s = + case rest' of + [] -> [chunk] + _:rest -> chunk : split rest + where + chunk = + case chunk' of +#ifdef mingw32_HOST_OS + ('\"':xs@(_:_)) | last xs == '\"' -> init xs +#endif + _ -> chunk' + + (chunk', rest') = break (==searchPathSeparator) s + +-- | A platform-specific character used to separate search path strings in +-- environment variables. The separator is a colon (\":\") on Unix and Macintosh, +-- and a semicolon (\";\") on the Windows operating system. +searchPathSeparator :: Char +#if mingw32_HOST_OS || mingw32_TARGET_OS +searchPathSeparator = ';' +#else +searchPathSeparator = ':' +#endif +