X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Futils%2Fghc-pkg%2FMain.hs;h=5f9d4c30eef00f235c76ff22c8954f7ae9b1608d;hb=b89373082160548225901a4963523fac8c977a15;hp=a3aa329de4fa2f58fb261c77e3d243877b1a9f02;hpb=f6072cc4e89e50de957607e82bea904659014548;p=ghc-hetmet.git diff --git a/ghc/utils/ghc-pkg/Main.hs b/ghc/utils/ghc-pkg/Main.hs index a3aa329..5f9d4c3 100644 --- a/ghc/utils/ghc-pkg/Main.hs +++ b/ghc/utils/ghc-pkg/Main.hs @@ -18,20 +18,15 @@ 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 qualified Control.Exception as Exception -import System.FilePath ( joinFileName ) import Prelude -#if __GLASGOW_HASKELL__ < 603 -#include "config.h" -#endif +#include "../../includes/ghcconfig.h" #if __GLASGOW_HASKELL__ >= 504 import System.Console.GetOpt @@ -52,7 +47,7 @@ import System ( getArgs, getProgName, import System.IO import Data.List ( isPrefixOf, isSuffixOf, intersperse ) -#ifdef mingw32_TARGET_OS +#ifdef mingw32_HOST_OS import Foreign #if __GLASGOW_HASKELL__ >= 504 @@ -131,14 +126,15 @@ ourCopyright = "GHC package manager version " ++ version ++ "\n" usageHeader :: String -> String usageHeader prog = substProg prog $ "Usage:\n" ++ - " $p {--help | -?}\n" ++ - " Produce this usage message.\n" ++ - "\n" ++ - " $p register {filename | -} [--user | --global]\n" ++ + " $p register {filename | -}\n" ++ " Register the package using the specified installed package\n" ++ " description. The syntax for the latter is given in the $p\n" ++ " documentation.\n" ++ "\n" ++ + " $p update {filename | -}\n" ++ + " Register the package, overwriting any other package with the\n" ++ + " same name.\n" ++ + "\n" ++ " $p unregister {pkg-id}\n" ++ " Unregister the specified package.\n" ++ "\n" ++ @@ -148,9 +144,9 @@ usageHeader prog = substProg prog $ " $p hide {pkg-id}\n" ++ " Hide the specified package.\n" ++ "\n" ++ - " $p list [--global | --user]\n" ++ - " List all registered packages, both global and user (unless either\n" ++ - " --global or --user is specified), and both hidden and exposed.\n" ++ + " $p list\n" ++ + " List registered packages in the global database, and also the" ++ + " user database if --user is given.\n" ++ "\n" ++ " $p describe {pkg-id}\n" ++ " Give the registered description for the specified package. The\n" ++ @@ -159,7 +155,9 @@ usageHeader prog = substProg prog $ "\n" ++ " $p field {pkg-id} {field}\n" ++ " Extract the specified field of the package description for the\n" ++ - " specified package.\n" + " specified package.\n" ++ + "\n" ++ + " The following optional flags are also accepted:\n" substProg :: String -> String -> String substProg _ [] = [] @@ -172,8 +170,6 @@ substProg prog (c:xs) = c : substProg prog xs runit :: [Flag] -> [String] -> IO () runit cli nonopts = do prog <- getProgramName - dbs <- getPkgDatabases cli - db_stack <- mapM readParseDatabase dbs let force = FlagForce `elem` cli auto_ghci_libs = FlagAutoGHCiLibs `elem` cli @@ -181,26 +177,26 @@ runit cli nonopts = do -- first, parse the command case nonopts of ["register", filename] -> - registerPackage filename [] db_stack auto_ghci_libs False force + registerPackage filename [] cli auto_ghci_libs False force ["update", filename] -> - registerPackage filename [] db_stack auto_ghci_libs True force + registerPackage filename [] cli auto_ghci_libs True force ["unregister", pkgid_str] -> do - pkgid <- readPkgId pkgid_str - unregisterPackage pkgid db_stack + pkgid <- readGlobPkgId pkgid_str + unregisterPackage pkgid cli ["expose", pkgid_str] -> do - pkgid <- readPkgId pkgid_str - exposePackage pkgid db_stack + pkgid <- readGlobPkgId pkgid_str + exposePackage pkgid cli ["hide", pkgid_str] -> do - pkgid <- readPkgId pkgid_str - hidePackage pkgid db_stack + pkgid <- readGlobPkgId pkgid_str + hidePackage pkgid cli ["list"] -> do - listPackages db_stack + listPackages cli ["describe", pkgid_str] -> do - pkgid <- readPkgId pkgid_str - describePackage db_stack pkgid + pkgid <- readGlobPkgId pkgid_str + describePackage cli pkgid ["field", pkgid_str, field] -> do - pkgid <- readPkgId pkgid_str - describeField db_stack pkgid field + pkgid <- readGlobPkgId pkgid_str + describeField cli pkgid field [] -> do die ("missing command\n" ++ usageInfo (usageHeader prog) flags) @@ -217,6 +213,20 @@ parseCheck parser str what = readPkgId :: String -> IO PackageIdentifier readPkgId str = parseCheck parsePackageId str "package identifier" +readGlobPkgId :: String -> IO PackageIdentifier +readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier" + +parseGlobPackageId :: ReadP r PackageIdentifier +parseGlobPackageId = + parsePackageId + +++ + (do n <- parsePackageName; string "-*" + return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion })) + +-- globVersion means "all versions" +globVersion :: Version +globVersion = Version{ versionBranch=[], versionTags=["*"] } + -- ----------------------------------------------------------------------------- -- Package databases @@ -236,12 +246,8 @@ type PackageDBStack = [(PackageDBName,PackageDB)] -- A stack of package databases. Convention: head is the topmost -- in the stack. Earlier entries override later one. --- The output of this function is the list of databases to act upon, with --- the "topmost" overlapped database last. The commands which operate on a --- single database will use the last one. Commands which operate on multiple --- databases will interpret the databases as overlapping. -getPkgDatabases :: [Flag] -> IO [PackageDBName] -getPkgDatabases flags = do +getPkgDatabases :: Bool -> [Flag] -> IO PackageDBStack +getPkgDatabases modify flags = do -- first we determine the location of the global package config. On Windows, -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the -- location is passed to the binary using the --global-config flag by the @@ -269,25 +275,34 @@ getPkgDatabases flags = do writeFile user_conf emptyPackageConfig let - databases = foldl addDB [global_conf] flags + -- 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 + | otherwise = foldl addDB [user_conf,global_conf] flags -- implement the following rules: - -- global database is the default -- --user means overlap with the user database -- --global means reset to just the global database -- -f means overlap with - addDB dbs FlagUser = user_conf : dbs + addDB dbs FlagUser = if user_conf `elem` dbs + then dbs + else user_conf : dbs addDB dbs FlagGlobal = [global_conf] addDB dbs (FlagConfig f) = f : dbs addDB dbs _ = dbs - return databases + db_stack <- mapM readParseDatabase databases + return db_stack 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) @@ -300,14 +315,15 @@ emptyPackageConfig = "[]" registerPackage :: FilePath -> [(String,String)] -- defines, ToDo: maybe remove? - -> PackageDBStack + -> [Flag] -> Bool -- auto_ghci_libs -> Bool -- update -> Bool -- force -> IO () -registerPackage input defines db_stack auto_ghci_libs update force = do +registerPackage input defines flags auto_ghci_libs update force = do + db_stack <- getPkgDatabases True flags let - db_to_operate_on = head db_stack + db_to_operate_on = my_head "db" db_stack db_filename = fst db_to_operate_on -- checkConfigAccess db_filename @@ -340,48 +356,44 @@ parsePackageInfo str defines force = ParseOk ok -> return ok ParseFailed err -> die (showError err) --- Used for converting versionless package names to new --- PackageIdentifiers. "Version [] []" is special: it means "no --- version" or "any version" -pkgNameToId :: String -> PackageIdentifier -pkgNameToId name = PackageIdentifier name (Version [] []) - -- ----------------------------------------------------------------------------- -- Exposing, Hiding, Unregistering are all similar -exposePackage :: PackageIdentifier -> PackageDBStack -> IO () +exposePackage :: PackageIdentifier -> [Flag] -> IO () exposePackage = modifyPackage (\p -> [p{exposed=True}]) -hidePackage :: PackageIdentifier -> PackageDBStack -> IO () +hidePackage :: PackageIdentifier -> [Flag] -> IO () hidePackage = modifyPackage (\p -> [p{exposed=False}]) -unregisterPackage :: PackageIdentifier -> PackageDBStack -> IO () +unregisterPackage :: PackageIdentifier -> [Flag] -> IO () unregisterPackage = modifyPackage (\p -> []) modifyPackage :: (InstalledPackageInfo -> [InstalledPackageInfo]) -> PackageIdentifier - -> PackageDBStack + -> [Flag] -> IO () -modifyPackage _ _ [] = error "modifyPackage" -modifyPackage fn pkgid ((db_name, pkgs) : _) = do +modifyPackage fn pkgid flags = do + db_stack <- getPkgDatabases True{-modify-} flags + let ((db_name, pkgs) : _) = db_stack checkConfigAccess db_name - p <- findPackage [(db_name,pkgs)] pkgid - let pid = package p + ps <- findPackages [(db_name,pkgs)] pkgid + let pids = map package ps savePackageConfig db_name let new_config = concat (map modify pkgs) modify pkg - | package pkg == pid = fn pkg - | otherwise = [pkg] + | package pkg `elem` pids = fn pkg + | otherwise = [pkg] maybeRestoreOldConfig db_name $ - writeNewConfig db_name new_config + writeNewConfig db_name new_config -- ----------------------------------------------------------------------------- -- Listing packages -listPackages :: PackageDBStack -> IO () -listPackages db_confs = do - mapM_ show_pkgconf (reverse db_confs) +listPackages :: [Flag] -> IO () +listPackages flags = do + db_stack <- getPkgDatabases False flags + mapM_ show_pkgconf (reverse db_stack) where show_pkgconf (db_name,pkg_confs) = hPutStrLn stdout (render $ text (db_name ++ ":") $$ nest 4 packages @@ -395,38 +407,48 @@ listPackages db_confs = do -- ----------------------------------------------------------------------------- -- Describe -describePackage :: PackageDBStack -> PackageIdentifier -> IO () -describePackage db_stack pkgid = do - p <- findPackage db_stack pkgid - putStrLn (showInstalledPackageInfo p) +describePackage :: [Flag] -> PackageIdentifier -> IO () +describePackage flags pkgid = do + db_stack <- getPkgDatabases False flags + ps <- findPackages db_stack pkgid + mapM_ (putStrLn . showInstalledPackageInfo) ps -findPackage :: PackageDBStack -> PackageIdentifier -> IO InstalledPackageInfo -findPackage db_stack pkgid +-- PackageId is can have globVersion for the version +findPackages :: PackageDBStack -> PackageIdentifier -> IO [InstalledPackageInfo] +findPackages db_stack pkgid = case [ p | p <- all_pkgs, pkgid `matches` p ] of [] -> die ("cannot find package " ++ showPackageId pkgid) - [p] -> return p - ps -> die ("package " ++ showPackageId pkgid ++ + [p] -> return [p] + -- if the version is globVersion, then we are allowed to match + -- multiple packages. So eg. "Cabal-*" matches all Cabal packages, + -- but "Cabal" matches just one Cabal package - if there are more, + -- you get an error. + ps | versionTags (pkgVersion pkgid) == versionTags globVersion + -> return ps + | otherwise + -> die ("package " ++ showPackageId pkgid ++ " matches multiple packages: " ++ concat (intersperse ", " ( map (showPackageId.package) ps))) where - all_pkgs = concat (map snd db_stack) + pid `matches` pkg + = (pkgName pid == pkgName p) + && (pkgVersion pid == pkgVersion p || not (realVersion pid)) + where p = package pkg -matches :: PackageIdentifier -> InstalledPackageInfo -> Bool -pid `matches` p = - pid == package p || - not (realVersion pid) && pkgName pid == pkgName (package p) + all_pkgs = concat (map snd db_stack) -- ----------------------------------------------------------------------------- -- Field -describeField :: PackageDBStack -> PackageIdentifier -> String -> IO () -describeField db_stack pkgid field = do +describeField :: [Flag] -> PackageIdentifier -> String -> IO () +describeField flags pkgid field = do + db_stack <- getPkgDatabases False flags case toField field of Nothing -> die ("unknown field: " ++ field) Just fn -> do - p <- findPackage db_stack pkgid - putStrLn (fn p) + ps <- findPackages db_stack pkgid + mapM_ (putStrLn.fn) ps toField :: String -> Maybe (InstalledPackageInfo -> String) -- backwards compatibility: @@ -438,10 +460,10 @@ toField "extra_libraries" = Just $ strList . extraLibraries toField "include_dirs" = Just $ strList . includeDirs toField "c_includes" = Just $ strList . includes toField "package_deps" = Just $ strList . map showPackageId. depends -toField "extra_cc_opts" = Just $ strList . extraCcOpts -toField "extra_ld_opts" = Just $ strList . extraLdOpts +toField "extra_cc_opts" = Just $ strList . ccOptions +toField "extra_ld_opts" = Just $ strList . ldOptions toField "framework_dirs" = Just $ strList . frameworkDirs -toField "extra_frameworks"= Just $ strList . extraFrameworks +toField "extra_frameworks"= Just $ strList . frameworks toField s = showInstalledPackageInfoField s strList :: [String] -> String @@ -505,6 +527,7 @@ validatePackageConfig :: InstalledPackageInfo -> Bool -- force -> IO () validatePackageConfig pkg db_stack auto_ghci_libs update force = do + checkPackageId pkg checkDuplicates db_stack pkg update mapM_ (checkDep db_stack force) (depends pkg) mapM_ (checkDir force) (importDirs pkg) @@ -515,6 +538,17 @@ validatePackageConfig pkg db_stack auto_ghci_libs update force = do -- extra_libraries :: [String], -- c_includes :: [String], +-- 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 +-- we check that the package id can be parsed properly here. +checkPackageId :: InstalledPackageInfo -> IO () +checkPackageId ipi = + let str = showPackageId (package ipi) in + case [ x | (x,ys) <- readP_to_S parsePackageId str, all isSpace ys ] of + [_] -> return () + [] -> die ("invalid package identifier: " ++ str) + _ -> die ("ambiguous package identifier: " ++ str) checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> IO () checkDuplicates db_stack pkg update = do @@ -539,7 +573,7 @@ checkDuplicates db_stack pkg update = do when (not update && exposed pkg && not (null exposed_pkgs_with_same_name)) $ die ("trying to register " ++ showPackageId pkgid ++ " as exposed, but " - ++ showPackageId (package (head exposed_pkgs_with_same_name)) + ++ showPackageId (package (my_head "when" exposed_pkgs_with_same_name)) ++ " is also exposed.") @@ -603,7 +637,7 @@ autoBuildGHCiLib dir batch_file ghci_file = do let ghci_lib_file = dir ++ '/':ghci_file batch_lib_file = dir ++ '/':batch_file hPutStr stderr ("building GHCi library " ++ ghci_lib_file ++ "...") -#if defined(darwin_TARGET_OS) +#if defined(darwin_HOST_OS) r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file] #elif defined(mingw32_HOST_OS) execDir <- getExecDir "/bin/ghc-pkg.exe" @@ -624,18 +658,28 @@ updatePackageDB -> IO [InstalledPackageInfo] updatePackageDB db_stack pkgs new_pkg = do let - -- we update dependencies without version numbers to - -- match the actual versions of the relevant packages instaled. + -- The input package spec is allowed to give a package dependency + -- without a version number; e.g. + -- depends: base + -- Here, we update these dependencies without version numbers to + -- match the actual versions of the relevant packages installed. updateDeps p = p{depends = map resolveDep (depends p)} - resolveDep pkgid - | realVersion pkgid = pkgid - | otherwise = lookupDep (pkgName pkgid) - - lookupDep name - = head [ pid | p <- concat (map snd db_stack), + resolveDep dep_pkgid + | realVersion dep_pkgid = dep_pkgid + | otherwise = lookupDep dep_pkgid + + lookupDep dep_pkgid + = let + name = pkgName dep_pkgid + in + case [ pid | p <- concat (map snd db_stack), let pid = package p, - pkgName pid == name ] + pkgName pid == name ] of + (pid:_) -> pid -- Found installed package, + -- replete with its version + [] -> dep_pkgid -- No installed package; use + -- the version-less one is_exposed = exposed new_pkg pkgid = package new_pkg @@ -753,36 +797,46 @@ oldFlags = [ oldRunit :: [OldFlag] -> IO () oldRunit clis = do - let config_flags = [ f | Just f <- map conv clis ] + let new_flags = [ f | Just f <- map conv clis ] conv (OF_GlobalConfig f) = Just (FlagGlobalConfig f) conv (OF_Config f) = Just (FlagConfig f) conv _ = Nothing - db_names <- getPkgDatabases config_flags - db_stack <- mapM readParseDatabase db_names + let fields = [ f | OF_Field f <- clis ] let auto_ghci_libs = any isAuto clis where isAuto OF_AutoGHCiLibs = True; isAuto _ = False - input_file = head ([ f | (OF_Input f) <- clis] ++ ["-"]) + input_file = my_head "inp" ([ f | (OF_Input f) <- clis] ++ ["-"]) force = OF_Force `elem` clis defines = [ (nm,val) | OF_DefinedName nm val <- clis ] case [ c | c <- clis, isAction c ] of - [ OF_List ] -> listPackages db_stack - [ OF_ListLocal ] -> listPackages db_stack - [ OF_Add upd ] -> registerPackage input_file defines db_stack - auto_ghci_libs upd force - [ OF_Remove p ] -> unregisterPackage (pkgNameToId p) db_stack - [ OF_Show p ] - | null fields -> describePackage db_stack (pkgNameToId p) - | otherwise -> mapM_ (describeField db_stack (pkgNameToId p)) fields - _ -> do prog <- getProgramName - die (usageInfo (usageHeader prog) flags) + [ OF_List ] -> listPackages new_flags + [ OF_ListLocal ] -> listPackages new_flags + [ OF_Add upd ] -> + registerPackage input_file defines new_flags auto_ghci_libs upd force + [ OF_Remove pkgid_str ] -> do + pkgid <- readPkgId pkgid_str + unregisterPackage pkgid new_flags + [ OF_Show pkgid_str ] + | null fields -> do + pkgid <- readPkgId pkgid_str + describePackage new_flags pkgid + | otherwise -> do + pkgid <- readPkgId pkgid_str + mapM_ (describeField new_flags pkgid) fields + _ -> do + prog <- getProgramName + die (usageInfo (usageHeader prog) flags) + +my_head :: String -> [a] -> a +my_head s [] = error s +my_head s (x:xs) = x -- --------------------------------------------------------------------------- @@ -900,7 +954,7 @@ dieOrForce force s ----------------------------------------- -- Cut and pasted from ghc/compiler/SysTools -#if defined(mingw32_TARGET_OS) +#if defined(mingw32_HOST_OS) subst a b ls = map (\ x -> if x == a then b else x) ls unDosifyPath xs = subst '\\' '/' xs @@ -925,3 +979,45 @@ foreign import stdcall unsafe "GetModuleFileNameA" getExecDir :: String -> IO (Maybe String) getExecDir _ = return Nothing #endif + +-- ----------------------------------------------------------------------------- +-- FilePath utils + +-- | The 'joinFileName' function is the opposite of 'splitFileName'. +-- It joins directory and file names to form a complete file path. +-- +-- The general rule is: +-- +-- > dir `joinFileName` basename == path +-- > where +-- > (dir,basename) = splitFileName path +-- +-- There might be an exceptions to the rule but in any case the +-- reconstructed path will refer to the same object (file or directory). +-- An example exception is that on Windows some slashes might be converted +-- to backslashes. +joinFileName :: String -> String -> FilePath +joinFileName "" fname = fname +joinFileName "." fname = fname +joinFileName dir "" = dir +joinFileName dir fname + | isPathSeparator (last dir) = dir++fname + | otherwise = dir++pathSeparator:fname + +-- | Checks whether the character is a valid path separator for the host +-- platform. The valid character is a 'pathSeparator' but since the Windows +-- operating system also accepts a slash (\"\/\") since DOS 2, the function +-- checks for it on this platform, too. +isPathSeparator :: Char -> Bool +isPathSeparator ch = ch == pathSeparator || ch == '/' + +-- | Provides a platform-specific character used to separate directory levels in +-- a path string that reflects a hierarchical file system organization. The +-- separator is a slash (@\"\/\"@) on Unix and Macintosh, and a backslash +-- (@\"\\\"@) on the Windows operating system. +pathSeparator :: Char +#ifdef mingw32_HOST_OS +pathSeparator = '\\' +#else +pathSeparator = '/' +#endif