X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Futils%2Fghc-pkg%2FMain.hs;h=9e67cf0b15451c8f8134e602f1658c6438d0ce34;hb=7ff8f386460e99bf27e65a50709a9f352014c3c8;hp=466806acde56a0140fa2b94dfdd754491705577f;hpb=e0ccc77e839b7150a731301046f7488078b241f9;p=ghc-hetmet.git diff --git a/ghc/utils/ghc-pkg/Main.hs b/ghc/utils/ghc-pkg/Main.hs index 466806a..9e67cf0 100644 --- a/ghc/utils/ghc-pkg/Main.hs +++ b/ghc/utils/ghc-pkg/Main.hs @@ -9,7 +9,6 @@ -- TODO: -- - validate modules --- - expose/hide -- - expanding of variables in new-style package conf -- - version manipulation (checking whether old version exists, -- hiding old version?) @@ -19,18 +18,17 @@ module Main (main) where import Version ( version, targetOS, targetARCH ) import Distribution.InstalledPackageInfo import Distribution.Compat.ReadP -import Distribution.ParseUtils ( showError ) +import Distribution.ParseUtils ( showError, ParseResult(..) ) import Distribution.Package import Distribution.Version -import Compat.Directory ( getAppUserDataDirectory ) +import Compat.Directory ( getAppUserDataDirectory, createDirectoryIfMissing ) +import Compat.RawSystem ( rawSystem ) import Control.Exception ( evaluate ) import qualified Control.Exception as Exception import Prelude -#if __GLASGOW_HASKELL__ < 603 -#include "config.h" -#endif +#include "../../includes/ghcconfig.h" #if __GLASGOW_HASKELL__ >= 504 import System.Console.GetOpt @@ -46,14 +44,11 @@ import Data.Char ( isSpace ) import Monad import Directory import System ( getArgs, getProgName, - system, exitWith, - ExitCode(..) + exitWith, ExitCode(..) ) import System.IO import Data.List ( isPrefixOf, isSuffixOf, intersperse ) -#include "../../includes/ghcconfig.h" - #ifdef mingw32_HOST_OS import Foreign @@ -77,7 +72,7 @@ main = do bye (usageInfo (usageHeader prog) flags) (cli,_,[]) | FlagVersion `elem` cli -> bye ourCopyright - (cli@(_:_),nonopts,[]) -> + (cli,nonopts,[]) -> runit cli nonopts (_,_,errors) -> tryOldCmdLine errors args @@ -133,14 +128,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" ++ @@ -150,9 +146,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" ++ @@ -161,7 +157,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 _ [] = [] @@ -262,11 +260,12 @@ getPkgDatabases flags = do let subdir = targetARCH ++ '-':targetOS ++ '-':version - user_conf = appdir `joinFileName` subdir `joinFileName` "package.conf" + 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) - createParents user_conf + createDirectoryIfMissing True archdir writeFile user_conf emptyPackageConfig let @@ -308,7 +307,7 @@ registerPackage :: FilePath -> IO () registerPackage input defines db_stack auto_ghci_libs update force = do 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 @@ -338,14 +337,8 @@ parsePackageInfo -> IO InstalledPackageInfo parsePackageInfo str defines force = case parseInstalledPackageInfo str of - Right ok -> return ok - Left 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 [] []) + ParseOk ok -> return ok + ParseFailed err -> die (showError err) -- ----------------------------------------------------------------------------- -- Exposing, Hiding, Unregistering are all similar @@ -388,8 +381,10 @@ listPackages db_confs = do text (db_name ++ ":") $$ nest 4 packages ) where packages = fsep (punctuate comma (map pp_pkg pkg_confs)) - pp_pkg = text . showPackageId . package - + pp_pkg p + | exposed p = doc + | otherwise = parens doc + where doc = text (showPackageId (package p)) -- ----------------------------------------------------------------------------- -- Describe @@ -504,6 +499,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) @@ -514,6 +510,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 @@ -538,14 +545,14 @@ 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.") checkDir :: Bool -> String -> IO () checkDir force d - | "$libdir" `isPrefixOf` d = return () - -- can't check this, because we don't know what $libdir is + | "$topdir" `isPrefixOf` d = return () + -- can't check this, because we don't know what $topdir is | otherwise = do there <- doesDirectoryExist d when (not there) @@ -574,13 +581,13 @@ checkHSLib dirs auto_ghci_libs force lib = do let batch_lib_file = "lib" ++ lib ++ ".a" bs <- mapM (doesLibExistIn batch_lib_file) dirs case [ dir | (exists,dir) <- zip bs dirs, exists ] of - [] -> dieOrForce force ("cannot find `" ++ batch_lib_file ++ - "' on library path") + [] -> dieOrForce force ("cannot find " ++ batch_lib_file ++ + " on library path") (dir:_) -> checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs doesLibExistIn :: String -> String -> IO Bool doesLibExistIn lib d - | "$libdir" `isPrefixOf` d = return True + | "$topdir" `isPrefixOf` d = return True | otherwise = doesFileExist (d ++ '/':lib) checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO () @@ -589,7 +596,7 @@ checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build | otherwise = do bs <- mapM (doesLibExistIn ghci_lib_file) dirs case [dir | (exists,dir) <- zip bs dirs, exists] of - [] -> hPutStrLn stderr ("warning: can't find GHCi lib `" ++ ghci_lib_file ++ "'") + [] -> hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file) (_:_) -> return () where ghci_lib_file = lib ++ ".o" @@ -601,17 +608,14 @@ autoBuildGHCiLib :: String -> String -> String -> IO () 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) - r <- system("ld -r -x -o " ++ ghci_lib_file ++ - " -all_load " ++ batch_lib_file) + hPutStr stderr ("building GHCi library " ++ ghci_lib_file ++ "...") +#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" - r <- system (maybe "" (++"/gcc-lib/") execDir++"ld -r -x -o " ++ - ghci_lib_file ++ " --whole-archive " ++ batch_lib_file) + r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file] #else - r <- system("ld -r -x -o " ++ ghci_lib_file ++ - " --whole-archive " ++ batch_lib_file) + r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file] #endif when (r /= ExitSuccess) $ exitWith r hPutStrLn stderr (" done.") @@ -626,18 +630,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 @@ -768,7 +782,7 @@ oldRunit clis = do 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 @@ -779,12 +793,22 @@ oldRunit clis = do [ 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_Remove pkgid_str ] -> do + pkgid <- readPkgId pkgid_str + unregisterPackage pkgid db_stack + [ OF_Show pkgid_str ] + | null fields -> do + pkgid <- readPkgId pkgid_str + describePackage db_stack pkgid + | otherwise -> do + pkgid <- readPkgId pkgid_str + mapM_ (describeField db_stack pkgid) fields + _ -> do + prog <- getProgramName + die (usageInfo (usageHeader prog) flags) + +my_head s [] = error s +my_head s (x:xs) = x -- --------------------------------------------------------------------------- @@ -899,17 +923,6 @@ dieOrForce force s | otherwise = die s ------------------------------------------------------------------------------ --- Create a hierarchy of directories - -createParents :: FilePath -> IO () -createParents dir = do - let parent = directoryOf dir - b <- doesDirectoryExist parent - when (not b) $ do - createParents parent - createDirectory parent - ----------------------------------------- -- Cut and pasted from ghc/compiler/SysTools @@ -940,44 +953,42 @@ getExecDir _ = return Nothing #endif -- ----------------------------------------------------------------------------- --- Utils from Krasimir's FilePath library, copied here for now - -directoryOf :: FilePath -> FilePath -directoryOf = fst.splitFileName - -splitFileName :: FilePath -> (String, String) -splitFileName p = (reverse (path2++drive), reverse fname) - where -#ifdef mingw32_TARGET_OS - (path,drive) = break (== ':') (reverse p) -#else - (path,drive) = (reverse p,"") -#endif - (fname,path1) = break isPathSeparator path - path2 = case path1 of - [] -> "." - [_] -> path1 -- don't remove the trailing slash if - -- there is only one character - (c:path) | isPathSeparator c -> path - _ -> path1 +-- 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 = -#ifdef mingw32_TARGET_OS - ch == '/' || ch == '\\' -#else - ch == '/' -#endif +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_TARGET_OS +#ifdef mingw32_HOST_OS pathSeparator = '\\' #else pathSeparator = '/'