X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Futils%2Fghc-pkg%2FMain.hs;h=1b5f8f75dd509843bc5d01a9c6cda1cb3822b63d;hb=153b9cb9b11e05c4edb1b6bc0a7b972660e41f70;hp=0bc8d4488320390b2c788592c88a98e0c360b48b;hpb=038f8bb5d97d018c60c6f19faddbf0ee76775027;p=ghc-hetmet.git diff --git a/ghc/utils/ghc-pkg/Main.hs b/ghc/utils/ghc-pkg/Main.hs index 0bc8d44..1b5f8f7 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,20 +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 System.FilePath ( joinFileName, splitFileName ) import Prelude -#if __GLASGOW_HASKELL__ < 603 -#include "config.h" -#endif +#include "../../includes/ghcconfig.h" #if __GLASGOW_HASKELL__ >= 504 import System.Console.GetOpt @@ -132,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" ++ @@ -149,7 +146,7 @@ usageHeader prog = substProg prog $ " $p hide {pkg-id}\n" ++ " Hide the specified package.\n" ++ "\n" ++ - " $p list [--global | --user]\n" ++ + " $p list\n" ++ " List all registered packages, both global and user (unless either\n" ++ " --global or --user is specified), and both hidden and exposed.\n" ++ "\n" ++ @@ -160,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 _ [] = [] @@ -261,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 @@ -307,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 @@ -337,8 +337,8 @@ parsePackageInfo -> IO InstalledPackageInfo parsePackageInfo str defines force = case parseInstalledPackageInfo str of - Right ok -> return ok - Left err -> die (showError err) + ParseOk ok -> return ok + ParseFailed err -> die (showError err) -- Used for converting versionless package names to new -- PackageIdentifiers. "Version [] []" is special: it means "no @@ -387,8 +387,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 @@ -537,14 +539,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) @@ -579,7 +581,7 @@ checkHSLib dirs auto_ghci_libs force lib = do 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 () @@ -601,7 +603,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" @@ -622,18 +624,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 @@ -764,7 +776,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 @@ -782,6 +794,9 @@ oldRunit clis = do _ -> do prog <- getProgramName die (usageInfo (usageHeader prog) flags) +my_head s [] = error s +my_head s (x:xs) = x + -- --------------------------------------------------------------------------- #ifdef OLD_STUFF @@ -895,17 +910,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 @@ -935,5 +939,44 @@ getExecDir :: String -> IO (Maybe String) getExecDir _ = return Nothing #endif -directoryOf :: FilePath -> FilePath -directoryOf = fst.splitFileName +-- ----------------------------------------------------------------------------- +-- 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