X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=b1aaaba7b09d0c11b38d3e688d00294f6f4cd8b6;hp=19be560ea0a1c271f0e8c678ec801b0fadf11346;hb=34cc75e1a62638f2833815746ebce0a9114dc26b;hpb=373b03fe979abe898a387e02ca22007b768e343e diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 19be560..b1aaaba 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# OPTIONS -fglasgow-exts -cpp #-} ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow 2004. @@ -8,69 +8,65 @@ ----------------------------------------------------------------------------- -- TODO: --- - validate modules --- - expanding of variables in new-style package conf --- - version manipulation (checking whether old version exists, --- hiding old version?) +-- * validate modules +-- * expanding of variables in new-style package conf +-- * version manipulation (checking whether old version exists, +-- hiding old version?) module Main (main) where -import Version ( version, targetOS, targetARCH ) -import Distribution.InstalledPackageInfo +import Version ( version, targetOS, targetARCH ) +import Distribution.ModuleName hiding (main) +import Distribution.InstalledPackageInfo hiding (depends) import Distribution.Compat.ReadP import Distribution.ParseUtils import Distribution.Package +import Distribution.Text import Distribution.Version - -#ifdef USING_COMPAT -import Compat.Directory ( getAppUserDataDirectory, createDirectoryIfMissing ) -import Compat.RawSystem ( rawSystem ) -#else -import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing ) +import System.FilePath import System.Cmd ( rawSystem ) -#endif +import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing ) import Prelude #include "../../includes/ghcconfig.h" -#if __GLASGOW_HASKELL__ >= 504 import System.Console.GetOpt import Text.PrettyPrint +#if __GLASGOW_HASKELL__ >= 609 import qualified Control.Exception as Exception -import Data.Maybe #else -import GetOpt -import Pretty -import qualified Exception -import Maybe +import qualified Control.Exception.Extensible as Exception #endif +import Data.Maybe -import Data.Char ( isSpace ) -import Monad -import Directory -import System ( getArgs, getProgName, getEnv, - exitWith, ExitCode(..) - ) +import Data.Char ( isSpace, toLower ) +import Control.Monad +import System.Directory ( doesDirectoryExist, getDirectoryContents, + doesFileExist, renameFile, removeFile ) +import System.Exit ( exitWith, ExitCode(..) ) +import System.Environment ( getArgs, getProgName, getEnv ) import System.IO -#if __GLASGOW_HASKELL__ >= 600 import System.IO.Error (try) -#else -import System.IO (try) -#endif -import Data.List ( isPrefixOf, isSuffixOf, intersperse, sortBy ) +import Data.List +import Control.Concurrent -#ifdef mingw32_HOST_OS import Foreign - -#if __GLASGOW_HASKELL__ >= 504 -import Foreign.C.String +import Foreign.C +#ifdef mingw32_HOST_OS +import GHC.ConsoleHandler #else -import CString -#endif +import System.Posix hiding (fdToHandle) #endif -import IO ( isPermissionError, isDoesNotExistError ) +import IO ( isPermissionError ) +import System.Posix.Internals +import GHC.Handle (fdToHandle) + +#if defined(GLOB) +import System.Process(runInteractiveCommand) +import qualified System.Info(os) +#endif -- ----------------------------------------------------------------------------- -- Entry point @@ -79,27 +75,17 @@ main :: IO () main = do args <- getArgs - case getOpt Permute flags args of - (cli,_,[]) | FlagHelp `elem` cli -> do - prog <- getProgramName - bye (usageInfo (usageHeader prog) flags) - (cli,_,[]) | FlagVersion `elem` cli -> - bye ourCopyright - (cli,nonopts,[]) -> - runit cli nonopts - (_,_,errors) -> tryOldCmdLine errors args - --- If the new command-line syntax fails, then we try the old. If that --- fails too, then we output the original errors and the new syntax --- (so the old syntax is still available, but hidden). -tryOldCmdLine :: [String] -> [String] -> IO () -tryOldCmdLine errors args = do - case getOpt Permute oldFlags args of - (cli@(_:_),[],[]) -> - oldRunit cli - _failed -> do - prog <- getProgramName - die (concat errors ++ usageInfo (usageHeader prog) flags) + case getOpt Permute (flags ++ deprecFlags) args of + (cli,_,[]) | FlagHelp `elem` cli -> do + prog <- getProgramName + bye (usageInfo (usageHeader prog) flags) + (cli,_,[]) | FlagVersion `elem` cli -> + bye ourCopyright + (cli,nonopts,[]) -> + runit cli nonopts + (_,_,errors) -> do + prog <- getProgramName + die (concat errors ++ usageInfo (usageHeader prog) flags) -- ----------------------------------------------------------------------------- -- Command-line syntax @@ -109,48 +95,54 @@ data Flag | FlagGlobal | FlagHelp | FlagVersion - | FlagConfig FilePath + | FlagConfig FilePath | FlagGlobalConfig FilePath | FlagForce | FlagForceFiles | FlagAutoGHCiLibs - | FlagDefinedName String String | FlagSimpleOutput + | FlagNamesOnly + | FlagIgnoreCase + | FlagNoUserDb deriving Eq flags :: [OptDescr Flag] flags = [ Option [] ["user"] (NoArg FlagUser) - "use the current user's package database", + "use the current user's package database", Option [] ["global"] (NoArg FlagGlobal) - "(default) use the global package database", + "use the global package database", Option ['f'] ["package-conf"] (ReqArg FlagConfig "FILE") - "act upon specified package config file (only)", + "use the specified package config file", Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE") - "location of the global package config", + "location of the global package config", + Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb) + "never read the user package database", Option [] ["force"] (NoArg FlagForce) - "ignore missing dependencies, directories, and libraries", + "ignore missing dependencies, directories, and libraries", Option [] ["force-files"] (NoArg FlagForceFiles) - "ignore missing directories and libraries only", + "ignore missing directories and libraries only", Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs) - "automatically build libs for GHCi (with register)", + "automatically build libs for GHCi (with register)", Option ['?'] ["help"] (NoArg FlagHelp) - "display this help and exit", - Option ['D'] ["define-name"] (ReqArg toDefined "NAME=VALUE") - "define NAME as VALUE", + "display this help and exit", Option ['V'] ["version"] (NoArg FlagVersion) - "output version information and exit", + "output version information and exit", Option [] ["simple-output"] (NoArg FlagSimpleOutput) - "print output in easy-to-parse format for some commands" + "print output in easy-to-parse format for some commands", + Option [] ["names-only"] (NoArg FlagNamesOnly) + "only print package names, not versions; can only be used with list --simple-output", + Option [] ["ignore-case"] (NoArg FlagIgnoreCase) + "ignore case for substring matching" + ] + +deprecFlags :: [OptDescr Flag] +deprecFlags = [ + -- put deprecated flags here ] - where - toDefined str = - case break (=='=') str of - (nm,[]) -> FlagDefinedName nm [] - (nm,_:val) -> FlagDefinedName nm val ourCopyright :: String -ourCopyright = "GHC package manager version " ++ version ++ "\n" +ourCopyright = "GHC package manager version " ++ Version.version ++ "\n" usageHeader :: String -> String usageHeader prog = substProg prog $ @@ -179,21 +171,48 @@ usageHeader prog = substProg prog $ " all the registered versions will be listed in ascending order.\n" ++ " Accepts the --simple-output flag.\n" ++ "\n" ++ - " $p latest pkg\n" ++ + " $p find-module {module}\n" ++ + " List registered packages exposing module {module} in the global\n" ++ + " database, and also the user database if --user is given.\n" ++ + " All the registered versions will be listed in ascending order.\n" ++ + " Accepts the --simple-output flag.\n" ++ + "\n" ++ + " $p latest {pkg-id}\n" ++ " Prints the highest registered version of a package.\n" ++ "\n" ++ " $p check\n" ++ " Check the consistency of package depenencies and list broken packages.\n" ++ " Accepts the --simple-output flag.\n" ++ "\n" ++ - " $p describe {pkg-id}\n" ++ + " $p describe {pkg}\n" ++ " Give the registered description for the specified package. The\n" ++ " description is returned in precisely the syntax required by $p\n" ++ " register.\n" ++ "\n" ++ - " $p field {pkg-id} {field}\n" ++ + " $p field {pkg} {field}\n" ++ " Extract the specified field of the package description for the\n" ++ - " specified package.\n" ++ + " specified package. Accepts comma-separated multiple fields.\n" ++ + "\n" ++ + " $p dump\n" ++ + " Dump the registered description for every package. This is like\n" ++ + " \"ghc-pkg describe '*'\", except that it is intended to be used\n" ++ + " by tools that parse the results, rather than humans.\n" ++ + "\n" ++ + " Substring matching is supported for {module} in find-module and\n" ++ + " for {pkg} in list, describe, and field, where a '*' indicates\n" ++ + " open substring ends (prefix*, *suffix, *infix*).\n" ++ + "\n" ++ + " When asked to modify a database (register, unregister, update,\n"++ + " hide, expose, and also check), ghc-pkg modifies the global database by\n"++ + " default. Specifying --user causes it to act on the user database,\n"++ + " or --package-conf can be used to act on another database\n"++ + " entirely. When multiple of these options are given, the rightmost\n"++ + " one is used as the database to act upon.\n"++ + "\n"++ + " Commands that query the package database (list, latest, describe,\n"++ + " field) operate on the list of databases specified by the flags\n"++ + " --user, --global, and --package-conf. If none of these flags are\n"++ + " given, the default is --global --user.\n"++ "\n" ++ " The following optional flags are also accepted:\n" @@ -205,74 +224,122 @@ substProg prog (c:xs) = c : substProg prog xs -- ----------------------------------------------------------------------------- -- Do the business -data Force = ForceAll | ForceFiles | NoForce +data Force = NoForce | ForceFiles | ForceAll | CannotForce + deriving (Eq,Ord) + +data PackageArg = Id PackageIdentifier | Substring String (String->Bool) runit :: [Flag] -> [String] -> IO () runit cli nonopts = do + installSignalHandlers -- catch ^C and clean up prog <- getProgramName let - force - | FlagForce `elem` cli = ForceAll + force + | FlagForce `elem` cli = ForceAll | FlagForceFiles `elem` cli = ForceFiles | otherwise = NoForce - auto_ghci_libs = FlagAutoGHCiLibs `elem` cli - defines = [ (nm,val) | FlagDefinedName nm val <- cli ] + auto_ghci_libs = FlagAutoGHCiLibs `elem` cli + splitFields fields = unfoldr splitComma (',':fields) + where splitComma "" = Nothing + splitComma fs = Just $ break (==',') (tail fs) + + substringCheck :: String -> Maybe (String -> Bool) + substringCheck "" = Nothing + substringCheck "*" = Just (const True) + substringCheck [_] = Nothing + substringCheck (h:t) = + case (h, init t, last t) of + ('*',s,'*') -> Just (isInfixOf (f s) . f) + ('*',_, _ ) -> Just (isSuffixOf (f t) . f) + ( _ ,s,'*') -> Just (isPrefixOf (f (h:s)) . f) + _ -> Nothing + where f | FlagIgnoreCase `elem` cli = map toLower + | otherwise = id +#if defined(GLOB) + glob x | System.Info.os=="mingw32" = do + -- glob echoes its argument, after win32 filename globbing + (_,o,_,_) <- runInteractiveCommand ("glob "++x) + txt <- hGetContents o + return (read txt) + glob x | otherwise = return [x] +#endif -- -- first, parse the command case nonopts of - ["register", filename] -> - registerPackage filename defines cli auto_ghci_libs False force - ["update", filename] -> - registerPackage filename defines cli auto_ghci_libs True force +#if defined(GLOB) + -- dummy command to demonstrate usage and permit testing + -- without messing things up; use glob to selectively enable + -- windows filename globbing for file parameters + -- register, update, FlagGlobalConfig, FlagConfig; others? + ["glob", filename] -> do + print filename + glob filename >>= print +#endif + ["register", filename] -> + registerPackage filename cli auto_ghci_libs False force + ["update", filename] -> + registerPackage filename cli auto_ghci_libs True force ["unregister", pkgid_str] -> do - pkgid <- readGlobPkgId pkgid_str - unregisterPackage pkgid cli + pkgid <- readGlobPkgId pkgid_str + unregisterPackage pkgid cli force ["expose", pkgid_str] -> do - pkgid <- readGlobPkgId pkgid_str - exposePackage pkgid cli + pkgid <- readGlobPkgId pkgid_str + exposePackage pkgid cli force ["hide", pkgid_str] -> do - pkgid <- readGlobPkgId pkgid_str - hidePackage pkgid cli + pkgid <- readGlobPkgId pkgid_str + hidePackage pkgid cli force ["list"] -> do - listPackages cli Nothing - ["list", pkgid_str] -> do - pkgid <- readGlobPkgId pkgid_str - listPackages cli (Just pkgid) + listPackages cli Nothing Nothing + ["list", pkgid_str] -> + case substringCheck pkgid_str of + Nothing -> do pkgid <- readGlobPkgId pkgid_str + listPackages cli (Just (Id pkgid)) Nothing + Just m -> listPackages cli (Just (Substring pkgid_str m)) Nothing + ["find-module", moduleName] -> do + let match = maybe (==moduleName) id (substringCheck moduleName) + listPackages cli Nothing (Just match) ["latest", pkgid_str] -> do - pkgid <- readGlobPkgId pkgid_str - latestPackage cli pkgid - ["describe", pkgid_str] -> do - pkgid <- readGlobPkgId pkgid_str - describePackage cli pkgid - ["field", pkgid_str, field] -> do - pkgid <- readGlobPkgId pkgid_str - describeField cli pkgid field + pkgid <- readGlobPkgId pkgid_str + latestPackage cli pkgid + ["describe", pkgid_str] -> + case substringCheck pkgid_str of + Nothing -> do pkgid <- readGlobPkgId pkgid_str + describePackage cli (Id pkgid) + Just m -> describePackage cli (Substring pkgid_str m) + ["field", pkgid_str, fields] -> + case substringCheck pkgid_str of + Nothing -> do pkgid <- readGlobPkgId pkgid_str + describeField cli (Id pkgid) (splitFields fields) + Just m -> describeField cli (Substring pkgid_str m) + (splitFields fields) ["check"] -> do - checkConsistency cli + checkConsistency cli + + ["dump"] -> do + dumpPackages cli + [] -> do - die ("missing command\n" ++ - usageInfo (usageHeader prog) flags) + die ("missing command\n" ++ + usageInfo (usageHeader prog) flags) (_cmd:_) -> do - die ("command-line syntax error\n" ++ - usageInfo (usageHeader prog) flags) + die ("command-line syntax error\n" ++ + usageInfo (usageHeader prog) flags) parseCheck :: ReadP a a -> String -> String -> IO a -parseCheck parser str what = +parseCheck parser str what = case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of [x] -> return x _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ 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 +parseGlobPackageId = + parse +++ - (do n <- parsePackageName; string "-*" + (do n <- parse + string "-*" return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion })) -- globVersion means "all versions" @@ -283,34 +350,42 @@ globVersion = Version{ versionBranch=[], versionTags=["*"] } -- Package databases -- Some commands operate on a single database: --- register, unregister, expose, hide +-- register, unregister, expose, hide -- however these commands also check the union of the available databases -- in order to check consistency. For example, register will check that -- dependencies exist before registering a package. -- -- Some commands operate on multiple databases, with overlapping semantics: --- list, describe, field +-- list, describe, field type PackageDBName = FilePath type PackageDB = [InstalledPackageInfo] -type PackageDBStack = [(PackageDBName,PackageDB)] - -- A stack of package databases. Convention: head is the topmost - -- in the stack. Earlier entries override later one. +type NamedPackageDB = (PackageDBName, PackageDB) +type PackageDBStack = [NamedPackageDB] + -- A stack of package databases. Convention: head is the topmost + -- in the stack. Earlier entries override later one. + +allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo] +allPackagesInStack = concatMap snd -getPkgDatabases :: Bool -> [Flag] -> IO PackageDBStack -getPkgDatabases modify flags = do +getPkgDatabases :: Bool -> [Flag] -> IO (PackageDBStack, Maybe PackageDBName) +getPkgDatabases modify my_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 -- wrapper script. let err_msg = "missing --global-conf option, location of global package.conf unknown\n" - global_conf <- - case [ f | FlagGlobalConfig f <- flags ] of - [] -> do mb_dir <- getExecDir "/bin/ghc-pkg.exe" - case mb_dir of - Nothing -> die err_msg - Just dir -> return (dir `joinFileName` "package.conf") + global_conf <- + case [ f | FlagGlobalConfig f <- my_flags ] of + [] -> do mb_dir <- getLibDir + case mb_dir of + Nothing -> die err_msg + Just dir -> + do let path = dir "package.conf" + exists <- doesFileExist path + unless exists $ die "Can't find package.conf" + return path fs -> return (last fs) let global_conf_dir = global_conf ++ ".d" @@ -323,116 +398,144 @@ getPkgDatabases modify flags = do , isSuffixOf ".conf" file] else return [] - -- get the location of the user package database, and create it if necessary - appdir <- getAppUserDataDirectory "ghc" + let no_user_db = FlagNoUserDb `elem` my_flags - let - subdir = targetARCH ++ '-':targetOS ++ '-':version - archdir = appdir `joinFileName` subdir - user_conf = archdir `joinFileName` "package.conf" - user_exists <- doesFileExist user_conf + -- get the location of the user package database, and create it if necessary + -- getAppUserDataDirectory can fail (e.g. if $HOME isn't set) + appdir <- try $ getAppUserDataDirectory "ghc" + + mb_user_conf <- + if no_user_db then return Nothing else + case appdir of + Right dir -> do + let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version + user_conf = dir subdir "package.conf" + user_exists <- doesFileExist user_conf + return (Just (user_conf,user_exists)) + Left _ -> + return Nothing -- 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_confs ++ [global_conf] - | otherwise = global_confs ++ [global_conf] + | Just (user_conf,user_exists) <- mb_user_conf, + modify || user_exists = user_conf : global_confs ++ [global_conf] + | otherwise = global_confs ++ [global_conf] - e_pkg_path <- try (getEnv "GHC_PACKAGE_PATH") + e_pkg_path <- try (System.Environment.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 - - -- The "global" database is always the one at the bottom of the stack. - -- This is the database we modify by default. + case e_pkg_path of + Left _ -> sys_databases + Right path + | last cs == "" -> init cs ++ sys_databases + | otherwise -> cs + where cs = parseSearchPath path + + -- The "global" database is always the one at the bottom of the stack. + -- This is the database we modify by default. virt_global_conf = last env_stack - -- -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 virt_global_conf - go (FlagConfig f : fs) = modifying f - go (_ : fs) = go fs - go [] = modifying virt_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 - - db_stack <- mapM readParseDatabase final_stack - return db_stack - -readParseDatabase :: PackageDBName -> IO (PackageDBName,PackageDB) -readParseDatabase filename = do - str <- readFile filename `Exception.catch` \_ -> return emptyPackageConfig - let packages = read str - Exception.evaluate packages - `Exception.catch` \_ -> - die (filename ++ ": parse error in package config file") - return (filename,packages) - -emptyPackageConfig :: String -emptyPackageConfig = "[]" + let db_flags = [ f | Just f <- map is_db_flag my_flags ] + where is_db_flag FlagUser + | Just (user_conf, _user_exists) <- mb_user_conf + = Just user_conf + is_db_flag FlagGlobal = Just virt_global_conf + is_db_flag (FlagConfig f) = Just f + is_db_flag _ = Nothing + + (final_stack, to_modify) <- + if not modify + then -- For a "read" command, we use all the databases + -- specified on the command line. If there are no + -- command-line flags specifying databases, the default + -- is to use all the ones we know about. + if null db_flags then return (env_stack, Nothing) + else return (reverse (nub db_flags), Nothing) + else let + -- For a "modify" command, treat all the databases as + -- a stack, where we are modifying the top one, but it + -- can refer to packages in databases further down the + -- stack. + + -- -f flags on the command line add to the database + -- stack, unless any of them are present in the stack + -- already. + flag_stack = filter (`notElem` env_stack) + [ f | FlagConfig f <- reverse my_flags ] + ++ env_stack + + -- the database we actually modify is the one mentioned + -- rightmost on the command-line. + to_modify = if null db_flags + then Just virt_global_conf + else Just (last db_flags) + in + return (flag_stack, to_modify) + + db_stack <- mapM (readParseDatabase mb_user_conf) final_stack + return (db_stack, to_modify) + +readParseDatabase :: Maybe (PackageDBName,Bool) + -> PackageDBName + -> IO (PackageDBName,PackageDB) +readParseDatabase mb_user_conf filename + -- the user database (only) is allowed to be non-existent + | Just (user_conf,False) <- mb_user_conf, filename == user_conf + = return (filename, []) + | otherwise + = do str <- readFile filename + let packages = map convertPackageInfoIn $ read str + Exception.evaluate packages + `catchError` \e-> + die ("error while parsing " ++ filename ++ ": " ++ show e) + return (filename,packages) -- ----------------------------------------------------------------------------- -- Registering registerPackage :: FilePath - -> [(String,String)] -- defines - -> [Flag] - -> Bool -- auto_ghci_libs - -> Bool -- update - -> Force - -> IO () -registerPackage input defines flags auto_ghci_libs update force = do - db_stack <- getPkgDatabases True flags + -> [Flag] + -> Bool -- auto_ghci_libs + -> Bool -- update + -> Force + -> IO () +registerPackage input my_flags auto_ghci_libs update force = do + (db_stack, Just to_modify) <- getPkgDatabases True my_flags let - db_to_operate_on = my_head "db" db_stack - db_filename = fst db_to_operate_on + db_to_operate_on = my_head "register" $ + filter ((== to_modify).fst) db_stack -- - s <- case input of "-" -> do - putStr "Reading package info from stdin ... " + putStr "Reading package info from stdin ... " getContents f -> do putStr ("Reading package info from " ++ show f ++ " ... ") - readFile f + readFile f - expanded <- expandEnvVars s defines force + expanded <- expandEnvVars s force - pkg0 <- parsePackageInfo expanded defines + pkg <- parsePackageInfo expanded putStrLn "done." - let pkg = resolveDeps db_stack pkg0 - validatePackageConfig pkg db_stack auto_ghci_libs update force + let unversioned_deps = filter (not . realVersion) (depends pkg) + unless (null unversioned_deps) $ + die ("Unversioned dependencies found: " ++ + unwords (map display unversioned_deps)) + + let truncated_stack = dropWhile ((/= to_modify).fst) db_stack + -- truncate the stack for validation, because we don't allow + -- packages lower in the stack to refer to those higher up. + validatePackageConfig pkg truncated_stack auto_ghci_libs update force let new_details = filter not_this (snd db_to_operate_on) ++ [pkg] not_this p = package p /= package pkg - savingOldConfig db_filename $ - writeNewConfig db_filename new_details + writeNewConfig to_modify new_details parsePackageInfo - :: String - -> [(String,String)] - -> IO InstalledPackageInfo -parsePackageInfo str defines = + :: String + -> IO InstalledPackageInfo +parsePackageInfo str = case parseInstalledPackageInfo str of ParseOk _warns ok -> return ok ParseFailed err -> case locatedErrorMsg err of @@ -442,114 +545,158 @@ parsePackageInfo str defines = -- ----------------------------------------------------------------------------- -- Exposing, Hiding, Unregistering are all similar -exposePackage :: PackageIdentifier -> [Flag] -> IO () +exposePackage :: PackageIdentifier -> [Flag] -> Force -> IO () exposePackage = modifyPackage (\p -> [p{exposed=True}]) -hidePackage :: PackageIdentifier -> [Flag] -> IO () +hidePackage :: PackageIdentifier -> [Flag] -> Force -> IO () hidePackage = modifyPackage (\p -> [p{exposed=False}]) -unregisterPackage :: PackageIdentifier -> [Flag] -> IO () -unregisterPackage = modifyPackage (\p -> []) +unregisterPackage :: PackageIdentifier -> [Flag] -> Force -> IO () +unregisterPackage = modifyPackage (\_ -> []) modifyPackage :: (InstalledPackageInfo -> [InstalledPackageInfo]) -> PackageIdentifier -> [Flag] + -> Force -> IO () -modifyPackage fn pkgid flags = do - db_stack <- getPkgDatabases True{-modify-} flags - let ((db_name, pkgs) : _) = db_stack - ps <- findPackages [(db_name,pkgs)] pkgid - let pids = map package ps - let new_config = concat (map modify pkgs) +modifyPackage fn pkgid my_flags force = do + (db_stack, Just _to_modify) <- getPkgDatabases True{-modify-} my_flags + ((db_name, pkgs), ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid) +-- let ((db_name, pkgs) : rest_of_stack) = db_stack +-- ps <- findPackages [(db_name,pkgs)] (Id pkgid) + let + pids = map package ps modify pkg - | package pkg `elem` pids = fn pkg - | otherwise = [pkg] - savingOldConfig db_name $ - writeNewConfig db_name new_config + | package pkg `elem` pids = fn pkg + | otherwise = [pkg] + new_config = concat (map modify pkgs) + + let + old_broken = brokenPackages (allPackagesInStack db_stack) + rest_of_stack = [ (nm, mypkgs) + | (nm, mypkgs) <- db_stack, nm /= db_name ] + new_stack = (db_name,new_config) : rest_of_stack + new_broken = map package (brokenPackages (allPackagesInStack new_stack)) + newly_broken = filter (`notElem` map package old_broken) new_broken + -- + when (not (null newly_broken)) $ + dieOrForceAll force ("unregistering " ++ display pkgid ++ + " would break the following packages: " + ++ unwords (map display newly_broken)) + + writeNewConfig db_name new_config -- ----------------------------------------------------------------------------- -- Listing packages -listPackages :: [Flag] -> Maybe PackageIdentifier -> IO () -listPackages flags mPackageName = do - let simple_output = FlagSimpleOutput `elem` flags - db_stack <- getPkgDatabases False flags +listPackages :: [Flag] -> Maybe PackageArg -> Maybe (String->Bool) -> IO () +listPackages my_flags mPackageName mModuleName = do + let simple_output = FlagSimpleOutput `elem` my_flags + (db_stack, _) <- getPkgDatabases False my_flags let db_stack_filtered -- if a package is given, filter out all other packages | Just this <- mPackageName = - map (\(conf,pkgs) -> (conf, filter (this `matchesPkg`) pkgs)) - db_stack + map (\(conf,pkgs) -> (conf, filter (this `matchesPkg`) pkgs)) + db_stack + | Just match <- mModuleName = -- packages which expose mModuleName + map (\(conf,pkgs) -> (conf, filter (match `exposedInPkg`) pkgs)) + db_stack | otherwise = db_stack - db_stack_sorted + db_stack_sorted = [ (db, sort_pkgs pkgs) | (db,pkgs) <- db_stack_filtered ] - where sort_pkgs = sortBy cmpPkgIds - cmpPkgIds pkg1 pkg2 = - case pkgName p1 `compare` pkgName p2 of - LT -> LT - GT -> GT - EQ -> pkgVersion p1 `compare` pkgVersion p2 - where (p1,p2) = (package pkg1, package pkg2) - - pkg_map = map (\p -> (package p, p)) $ concatMap snd db_stack + where sort_pkgs = sortBy cmpPkgIds + cmpPkgIds pkg1 pkg2 = + case pkgName p1 `compare` pkgName p2 of + LT -> LT + GT -> GT + EQ -> pkgVersion p1 `compare` pkgVersion p2 + where (p1,p2) = (package pkg1, package pkg2) + + match `exposedInPkg` pkg = any match (map display $ exposedModules pkg) + + pkg_map = allPackagesInStack db_stack show_func = if simple_output then show_simple else mapM_ (show_normal pkg_map) show_func (reverse db_stack_sorted) where show_normal pkg_map (db_name,pkg_confs) = - hPutStrLn stdout (render $ - text db_name <> colon $$ nest 4 packages - ) - where packages = fsep (punctuate comma (map pp_pkg pkg_confs)) - pp_pkg p - | isBrokenPackage p pkg_map = braces doc - | exposed p = doc - | otherwise = parens doc - where doc = text (showPackageId (package p)) - - show_simple db_stack = do - let pkgs = map showPackageId $ sortBy compPkgIdVer $ - map package (concatMap snd db_stack) - when (null pkgs) $ die "no matches" - hPutStrLn stdout $ concat $ intersperse " " pkgs + hPutStrLn stdout (render $ + text db_name <> colon $$ nest 4 packages + ) + where packages = fsep (punctuate comma (map pp_pkg pkg_confs)) + broken = map package (brokenPackages pkg_map) + pp_pkg p + | package p `elem` broken = braces doc + | exposed p = doc + | otherwise = parens doc + where doc = text (display (package p)) + + show_simple = simplePackageList my_flags . allPackagesInStack + +simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO () +simplePackageList my_flags pkgs = do + let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName + else display + strs = map showPkg $ sortBy compPkgIdVer $ map package pkgs + when (not (null pkgs)) $ + hPutStrLn stdout $ concat $ intersperse " " strs -- ----------------------------------------------------------------------------- -- Prints the highest (hidden or exposed) version of a package latestPackage :: [Flag] -> PackageIdentifier -> IO () -latestPackage flags pkgid = do - db_stack <- getPkgDatabases False flags - ps <- findPackages db_stack pkgid +latestPackage my_flags pkgid = do + (db_stack, _) <- getPkgDatabases False my_flags + ps <- findPackages db_stack (Id pkgid) show_pkg (sortBy compPkgIdVer (map package ps)) where show_pkg [] = die "no matches" - show_pkg pids = hPutStrLn stdout (showPackageId (last pids)) + show_pkg pids = hPutStrLn stdout (display (last pids)) -- ----------------------------------------------------------------------------- -- Describe -describePackage :: [Flag] -> PackageIdentifier -> IO () -describePackage flags pkgid = do - db_stack <- getPkgDatabases False flags - ps <- findPackages db_stack pkgid - mapM_ (putStrLn . showInstalledPackageInfo) ps +describePackage :: [Flag] -> PackageArg -> IO () +describePackage my_flags pkgarg = do + (db_stack, _) <- getPkgDatabases False my_flags + ps <- findPackages db_stack pkgarg + doDump ps + +dumpPackages :: [Flag] -> IO () +dumpPackages my_flags = do + (db_stack, _) <- getPkgDatabases False my_flags + doDump (allPackagesInStack db_stack) + +doDump :: [InstalledPackageInfo] -> IO () +doDump = mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo -- PackageId is can have globVersion for the version -findPackages :: PackageDBStack -> PackageIdentifier -> IO [InstalledPackageInfo] -findPackages db_stack pkgid - = case [ p | p <- all_pkgs, pkgid `matchesPkg` p ] of - [] -> die ("cannot find package " ++ showPackageId pkgid) - ps -> return ps +findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo] +findPackages db_stack pkgarg + = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg + +findPackagesByDB :: PackageDBStack -> PackageArg + -> IO [(NamedPackageDB, [InstalledPackageInfo])] +findPackagesByDB db_stack pkgarg + = case [ (db, matched) + | db@(_, pkgs) <- db_stack, + let matched = filter (pkgarg `matchesPkg`) pkgs, + not (null matched) ] of + [] -> die ("cannot find package " ++ pkg_msg pkgarg) + ps -> return ps where - all_pkgs = concat (map snd db_stack) + pkg_msg (Id pkgid) = display pkgid + pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat matches :: PackageIdentifier -> PackageIdentifier -> Bool pid `matches` pid' = (pkgName pid == pkgName pid') && (pkgVersion pid == pkgVersion pid' || not (realVersion pid)) -matchesPkg :: PackageIdentifier -> InstalledPackageInfo -> Bool -pid `matchesPkg` pkg = pid `matches` package pkg +matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool +(Id pid) `matchesPkg` pkg = pid `matches` package pkg +(Substring _ m) `matchesPkg` pkg = m (display (package pkg)) compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2 @@ -557,34 +704,41 @@ compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2 -- ----------------------------------------------------------------------------- -- Field -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 - ps <- findPackages db_stack pkgid - let top_dir = getFilenameDir (fst (last db_stack)) - mapM_ (putStrLn . fn) (mungePackagePaths top_dir ps) +describeField :: [Flag] -> PackageArg -> [String] -> IO () +describeField my_flags pkgarg fields = do + (db_stack, _) <- getPkgDatabases False my_flags + fns <- toFields fields + ps <- findPackages db_stack pkgarg + let top_dir = takeDirectory (fst (last db_stack)) + mapM_ (selectFields fns) (mungePackagePaths top_dir ps) + where toFields [] = return [] + toFields (f:fs) = case toField f of + Nothing -> die ("unknown field: " ++ f) + Just fn -> do fns <- toFields fs + return (fn:fns) + selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo] --- Replace the string "$topdir" at the beginning of a path +-- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path -- with the current topdir (obtained from the -B option). mungePackagePaths top_dir ps = map munge_pkg ps where munge_pkg p = p{ importDirs = munge_paths (importDirs p), - includeDirs = munge_paths (includeDirs p), - libraryDirs = munge_paths (libraryDirs p), - frameworkDirs = munge_paths (frameworkDirs p), - haddockInterfaces = munge_paths (haddockInterfaces p), - haddockHTMLs = munge_paths (haddockHTMLs p) + includeDirs = munge_paths (includeDirs p), + libraryDirs = munge_paths (libraryDirs p), + frameworkDirs = munge_paths (frameworkDirs p), + haddockInterfaces = munge_paths (haddockInterfaces p), + haddockHTMLs = munge_paths (haddockHTMLs p) } munge_paths = map munge_path - munge_path p - | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p' - | otherwise = p + munge_path p + | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p' + | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p' + | otherwise = p + + toHttpPath p = "file:///" ++ p maybePrefixMatch :: String -> String -> Maybe String maybePrefixMatch [] rest = Just rest @@ -602,12 +756,12 @@ toField "hs_libraries" = Just $ strList . hsLibraries 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 "package_deps" = Just $ strList . map display. depends 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 . frameworks -toField s = showInstalledPackageInfoField s +toField "framework_dirs" = Just $ strList . frameworkDirs +toField "extra_frameworks"= Just $ strList . frameworks +toField s = showInstalledPackageInfoField s strList :: [String] -> String strList = show @@ -617,204 +771,289 @@ strList = show -- Check: Check consistency of installed packages checkConsistency :: [Flag] -> IO () -checkConsistency flags = do - db_stack <- getPkgDatabases False flags - let pkgs = map (\p -> (package p, p)) $ concatMap snd db_stack - broken_pkgs = do - (pid, p) <- pkgs - let broken_deps = missingPackageDeps p pkgs - guard (not . null $ broken_deps) - return (pid, broken_deps) - mapM_ (putStrLn . render . show_func) broken_pkgs - where - show_func | FlagSimpleOutput `elem` flags = show_simple - | otherwise = show_normal - show_simple (pid,deps) = - text (showPackageId pid) <> colon - <+> fsep (punctuate comma (map (text . showPackageId) deps)) - show_normal (pid,deps) = - text "package" <+> text (showPackageId pid) <+> text "has missing dependencies:" - $$ nest 4 (fsep (punctuate comma (map (text . showPackageId) deps))) - -missingPackageDeps :: InstalledPackageInfo - -> [(PackageIdentifier, InstalledPackageInfo)] - -> [PackageIdentifier] -missingPackageDeps pkg pkg_map = - [ d | d <- depends pkg, isNothing (lookup d pkg_map)] ++ - [ d | d <- depends pkg, Just p <- return (lookup d pkg_map), isBrokenPackage p pkg_map] - -isBrokenPackage :: InstalledPackageInfo -> [(PackageIdentifier, InstalledPackageInfo)] -> Bool -isBrokenPackage pkg pkg_map = not . null $ missingPackageDeps pkg pkg_map +checkConsistency my_flags = do + (db_stack, _) <- getPkgDatabases True my_flags + -- check behaves like modify for the purposes of deciding which + -- databases to use, because ordering is important. + + let simple_output = FlagSimpleOutput `elem` my_flags + + let pkgs = allPackagesInStack db_stack + + checkPackage p = do + (_,es) <- runValidate $ checkPackageConfig p db_stack False True + if null es + then return [] + else do + when (not simple_output) $ do + reportError ("There are problems in package " ++ display (package p) ++ ":") + reportValidateErrors es " " Nothing + return () + return [p] + + broken_pkgs <- concat `fmap` mapM checkPackage pkgs + + let filterOut pkgs1 pkgs2 = filter not_in pkgs2 + where not_in p = package p `notElem` all_ps + all_ps = map package pkgs1 + + let not_broken_pkgs = filterOut broken_pkgs pkgs + (_, trans_broken_pkgs) = closure [] not_broken_pkgs + all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs + + when (not (null all_broken_pkgs)) $ do + if simple_output + then simplePackageList my_flags all_broken_pkgs + else do + reportError ("\nThe following packages are broken, either because they have a problem\n"++ + "listed above, or because they depend on a broken package.") + mapM_ (hPutStrLn stderr . display . package) all_broken_pkgs + + when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1) + + +closure :: [InstalledPackageInfo] -> [InstalledPackageInfo] + -> ([InstalledPackageInfo], [InstalledPackageInfo]) +closure pkgs db_stack = go pkgs db_stack + where + go avail not_avail = + case partition (depsAvailable avail) not_avail of + ([], not_avail') -> (avail, not_avail') + (new_avail, not_avail') -> go (new_avail ++ avail) not_avail' + + depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo + -> Bool + depsAvailable pkgs_ok pkg = null dangling + where dangling = filter (`notElem` pids) (depends pkg) + pids = map package pkgs_ok + + -- we want mutually recursive groups of package to show up + -- as broken. (#1750) +brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo] +brokenPackages pkgs = snd (closure [] pkgs) -- ----------------------------------------------------------------------------- -- Manipulating package.conf files +type InstalledPackageInfoString = InstalledPackageInfo_ String + +convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString +convertPackageInfoOut + (pkgconf@(InstalledPackageInfo { exposedModules = e, + hiddenModules = h })) = + pkgconf{ exposedModules = map display e, + hiddenModules = map display h } + +convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo +convertPackageInfoIn + (pkgconf@(InstalledPackageInfo { exposedModules = e, + hiddenModules = h })) = + pkgconf{ exposedModules = map convert e, + hiddenModules = map convert h } + where convert = fromJust . simpleParse + writeNewConfig :: FilePath -> [InstalledPackageInfo] -> IO () writeNewConfig filename packages = do hPutStr stdout "Writing new package config file... " - createDirectoryIfMissing True $ getFilenameDir filename - h <- openFile filename WriteMode `catch` \e -> + createDirectoryIfMissing True $ takeDirectory filename + let shown = concat $ intersperse ",\n " + $ map (show . convertPackageInfoOut) packages + fileContents = "[" ++ shown ++ "\n]" + writeFileAtomic filename fileContents + `catch` \e -> if isPermissionError e then die (filename ++ ": you don't have permission to modify this file") else ioError e - hPutStrLn h (show packages) - hClose h hPutStrLn stdout "done." -savingOldConfig :: FilePath -> IO () -> IO () -savingOldConfig filename io = Exception.block $ do - hPutStr stdout "Saving old package config file... " - -- mv rather than cp because we've already done an hGetContents - -- on this file so we won't be able to open it for writing - -- unless we move the old one out of the way... - let oldFile = filename ++ ".old" - restore_on_error <- catch (renameFile filename oldFile >> return True) $ - \err -> do - unless (isDoesNotExistError err) $ do - hPutStrLn stderr (unwords ["Unable to rename", show filename, - "to", show oldFile]) - ioError err - return False - hPutStrLn stdout "done." - io `catch` \e -> do - hPutStrLn stderr (show e) - hPutStr stdout ("\nWARNING: an error was encountered while writing" - ++ "the new configuration.\n") - when restore_on_error $ do - hPutStr stdout "Attempting to restore the old configuration..." - do renameFile oldFile filename - hPutStrLn stdout "done." - `catch` \err -> hPutStrLn stdout ("Failed: " ++ show err) - ioError e - ----------------------------------------------------------------------------- -- Sanity-check a new package config, and automatically build GHCi libs -- if requested. +type ValidateError = (Force,String) + +newtype Validate a = V { runValidate :: IO (a, [ValidateError]) } + +instance Monad Validate where + return a = V $ return (a, []) + m >>= k = V $ do + (a, es) <- runValidate m + (b, es') <- runValidate (k a) + return (b,es++es') + +verror :: Force -> String -> Validate () +verror f s = V (return ((),[(f,s)])) + +liftIO :: IO a -> Validate a +liftIO k = V (k >>= \a -> return (a,[])) + +-- returns False if we should die +reportValidateErrors :: [ValidateError] -> String -> Maybe Force -> IO Bool +reportValidateErrors es prefix mb_force = do + oks <- mapM report es + return (and oks) + where + report (f,s) + | Just force <- mb_force + = if (force >= f) + then do reportError (prefix ++ s ++ " (ignoring)") + return True + else if f < CannotForce + then do reportError (prefix ++ s ++ " (use --force to override)") + return False + else do reportError err + return False + | otherwise = do reportError err + return False + where + err = prefix ++ s + validatePackageConfig :: InstalledPackageInfo - -> PackageDBStack - -> Bool -- auto-ghc-libs - -> Bool -- update - -> Force - -> IO () + -> PackageDBStack + -> Bool -- auto-ghc-libs + -> Bool -- update, or check + -> Force + -> IO () validatePackageConfig pkg db_stack auto_ghci_libs update force = do + (_,es) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update + ok <- reportValidateErrors es (display (package pkg) ++ ": ") (Just force) + when (not ok) $ exitWith (ExitFailure 1) + +checkPackageConfig :: InstalledPackageInfo + -> PackageDBStack + -> Bool -- auto-ghc-libs + -> Bool -- update, or check + -> Validate () +checkPackageConfig pkg db_stack auto_ghci_libs update = do checkPackageId pkg checkDuplicates db_stack pkg update - mapM_ (checkDep db_stack force) (depends pkg) - mapM_ (checkDir force) (importDirs pkg) - mapM_ (checkDir force) (libraryDirs pkg) - mapM_ (checkDir force) (includeDirs pkg) - mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs force) (hsLibraries pkg) + mapM_ (checkDep db_stack) (depends pkg) + checkDuplicateDepends (depends pkg) + mapM_ (checkDir "import-dirs") (importDirs pkg) + mapM_ (checkDir "library-dirs") (libraryDirs pkg) + mapM_ (checkDir "include-dirs") (includeDirs pkg) + checkModules pkg + mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg) -- ToDo: check these somehow? - -- extra_libraries :: [String], - -- c_includes :: [String], + -- 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 +-- 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 :: InstalledPackageInfo -> Validate () checkPackageId ipi = - let str = showPackageId (package ipi) in - case [ x | (x,ys) <- readP_to_S parsePackageId str, all isSpace ys ] of + let str = display (package ipi) in + case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of [_] -> return () - [] -> die ("invalid package identifier: " ++ str) - _ -> die ("ambiguous package identifier: " ++ str) + [] -> verror CannotForce ("invalid package identifier: " ++ str) + _ -> verror CannotForce ("ambiguous package identifier: " ++ str) -resolveDeps :: PackageDBStack -> InstalledPackageInfo -> InstalledPackageInfo -resolveDeps db_stack p = updateDeps p - where - -- 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 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 ] of - (pid:_) -> pid -- Found installed package, - -- replete with its version - [] -> dep_pkgid -- No installed package; use - -- the version-less one - -checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> IO () +checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate () checkDuplicates db_stack pkg update = do let - pkgid = package pkg - (_top_db_name, pkgs) : _ = db_stack + pkgid = package pkg + (_top_db_name, pkgs) : _ = db_stack -- -- Check whether this package id already exists in this DB -- when (not update && (pkgid `elem` map package pkgs)) $ - die ("package " ++ showPackageId pkgid ++ " is already installed") + verror CannotForce $ + "package " ++ display pkgid ++ " is already installed" + let + uncasep = map toLower . display + dups = filter ((== uncasep pkgid) . uncasep) (map package pkgs) + + when (not update && not (null dups)) $ verror ForceAll $ + "Package names may be treated case-insensitively in the future.\n"++ + "Package " ++ display pkgid ++ + " overlaps with: " ++ unwords (map display dups) -checkDir :: Force -> String -> IO () -checkDir force d - | "$topdir" `isPrefixOf` d = return () - -- can't check this, because we don't know what $topdir is +checkDir :: String -> String -> Validate () +checkDir thisfield d + | "$topdir" `isPrefixOf` d = return () + | "$httptopdir" `isPrefixOf` d = return () + -- can't check these, because we don't know what $(http)topdir is | otherwise = do - there <- doesDirectoryExist d - when (not there) - (dieOrForceFile force (d ++ " doesn't exist or isn't a directory")) + there <- liftIO $ doesDirectoryExist d + when (not there) $ + verror ForceFiles (thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory") -checkDep :: PackageDBStack -> Force -> PackageIdentifier -> IO () -checkDep db_stack force pkgid +checkDep :: PackageDBStack -> PackageIdentifier -> Validate () +checkDep db_stack pkgid | pkgid `elem` pkgids || (not real_version && name_exists) = return () - | otherwise = dieOrForceAll force ("dependency " ++ showPackageId pkgid - ++ " doesn't exist") + | otherwise = verror ForceAll ("dependency " ++ display pkgid + ++ " doesn't exist") where - -- for backwards compat, we treat 0.0 as a special version, - -- and don't check that it actually exists. - real_version = realVersion pkgid - + -- for backwards compat, we treat 0.0 as a special version, + -- and don't check that it actually exists. + real_version = realVersion pkgid + name_exists = any (\p -> pkgName (package p) == name) all_pkgs name = pkgName pkgid - all_pkgs = concat (map snd db_stack) - pkgids = map package all_pkgs + all_pkgs = allPackagesInStack db_stack + pkgids = map package all_pkgs + +checkDuplicateDepends :: [PackageIdentifier] -> Validate () +checkDuplicateDepends deps + | null dups = return () + | otherwise = verror ForceAll ("package has duplicate dependencies: " ++ + unwords (map display dups)) + where + dups = [ p | (p:_:_) <- group (sort deps) ] realVersion :: PackageIdentifier -> Bool realVersion pkgid = versionBranch (pkgVersion pkgid) /= [] -checkHSLib :: [String] -> Bool -> Force -> String -> IO () -checkHSLib dirs auto_ghci_libs force lib = do +checkHSLib :: [String] -> Bool -> String -> Validate () +checkHSLib dirs auto_ghci_libs 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 - [] -> dieOrForceFile 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 - | "$topdir" `isPrefixOf` d = return True - | otherwise = doesFileExist (d ++ '/':lib) + m <- liftIO $ doesFileExistOnPath batch_lib_file dirs + case m of + Nothing -> verror ForceFiles ("cannot find " ++ batch_lib_file ++ + " on library path") + Just dir -> liftIO $ checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs + +doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath) +doesFileExistOnPath file path = go path + where go [] = return Nothing + go (p:ps) = do b <- doesFileExistIn file p + if b then return (Just p) else go ps + +doesFileExistIn :: String -> String -> IO Bool +doesFileExistIn lib d + | "$topdir" `isPrefixOf` d = return True + | "$httptopdir" `isPrefixOf` d = return True + | otherwise = doesFileExist (d lib) + +checkModules :: InstalledPackageInfo -> Validate () +checkModules pkg = do + mapM_ findModule (exposedModules pkg ++ hiddenModules pkg) + where + findModule modl = do + -- there's no .hi file for GHC.Prim + if modl == fromString "GHC.Prim" then return () else do + let file = toFilePath modl <.> "hi" + m <- liftIO $ doesFileExistOnPath file (importDirs pkg) + when (isNothing m) $ + verror ForceFiles ("file " ++ file ++ " is missing") checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO () checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file | 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) - (_:_) -> return () - where - ghci_lib_file = lib ++ ".o" + m <- doesFileExistOnPath ghci_lib_file dirs + when (isNothing m && ghci_lib_file /= "HSrts.o") $ + hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file) + where + ghci_lib_file = lib <.> "o" --- automatically build the GHCi version of a batch lib, +-- automatically build the GHCi version of a batch lib, -- using ld --whole-archive. autoBuildGHCiLib :: String -> String -> String -> IO () @@ -825,7 +1064,7 @@ autoBuildGHCiLib dir batch_file ghci_file = do #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" + execDir <- getLibDir r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file] #else r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file] @@ -839,7 +1078,7 @@ autoBuildGHCiLib dir batch_file ghci_file = do #if not_yet findModules :: [FilePath] -> IO [String] -findModules paths = +findModules paths = mms <- mapM searchDir paths return (concat mms) @@ -850,153 +1089,47 @@ searchDir path prefix = do searchEntries path prefix [] = return [] searchEntries path prefix (f:fs) | looks_like_a_module = do - ms <- searchEntries path prefix fs - return (prefix `joinModule` f : ms) + ms <- searchEntries path prefix fs + return (prefix `joinModule` f : ms) | looks_like_a_component = do - ms <- searchDir (path `joinFilename` f) (prefix `joinModule` f) + ms <- searchDir (path f) (prefix `joinModule` f) ms' <- searchEntries path prefix fs - return (ms ++ ms') + return (ms ++ ms') | otherwise - searchEntries path prefix fs + searchEntries path prefix fs where - (base,suffix) = splitFileExt f - looks_like_a_module = - suffix `elem` haskell_suffixes && - all okInModuleName base - looks_like_a_component = - null suffix && all okInModuleName base + (base,suffix) = splitFileExt f + looks_like_a_module = + suffix `elem` haskell_suffixes && + all okInModuleName base + looks_like_a_component = + null suffix && all okInModuleName base okInModuleName c #endif --- ----------------------------------------------------------------------------- --- The old command-line syntax, supported for backwards compatibility - -data OldFlag - = OF_Config FilePath - | OF_Input FilePath - | OF_List - | OF_ListLocal - | OF_Add Bool {- True => replace existing info -} - | OF_Remove String | OF_Show String - | OF_Field String | OF_AutoGHCiLibs | OF_Force - | OF_DefinedName String String - | OF_GlobalConfig FilePath - deriving (Eq) - -isAction :: OldFlag -> Bool -isAction OF_Config{} = False -isAction OF_Field{} = False -isAction OF_Input{} = False -isAction OF_AutoGHCiLibs{} = False -isAction OF_Force{} = False -isAction OF_DefinedName{} = False -isAction OF_GlobalConfig{} = False -isAction _ = True - -oldFlags :: [OptDescr OldFlag] -oldFlags = [ - Option ['f'] ["config-file"] (ReqArg OF_Config "FILE") - "use the specified package config file", - Option ['l'] ["list-packages"] (NoArg OF_List) - "list packages in all config files", - Option ['L'] ["list-local-packages"] (NoArg OF_ListLocal) - "list packages in the specified config file", - Option ['a'] ["add-package"] (NoArg (OF_Add False)) - "add a new package", - Option ['u'] ["update-package"] (NoArg (OF_Add True)) - "update package with new configuration", - Option ['i'] ["input-file"] (ReqArg OF_Input "FILE") - "read new package info from specified file", - Option ['s'] ["show-package"] (ReqArg OF_Show "NAME") - "show the configuration for package NAME", - Option [] ["field"] (ReqArg OF_Field "FIELD") - "(with --show-package) Show field FIELD only", - Option [] ["force"] (NoArg OF_Force) - "ignore missing directories/libraries", - Option ['r'] ["remove-package"] (ReqArg OF_Remove "NAME") - "remove an installed package", - Option ['g'] ["auto-ghci-libs"] (NoArg OF_AutoGHCiLibs) - "automatically build libs for GHCi (with -a)", - Option ['D'] ["define-name"] (ReqArg toDefined "NAME=VALUE") - "define NAME as VALUE", - Option [] ["global-conf"] (ReqArg OF_GlobalConfig "FILE") - "location of the global package config" - ] - where - toDefined str = - case break (=='=') str of - (nm,[]) -> OF_DefinedName nm [] - (nm,_:val) -> OF_DefinedName nm val - -oldRunit :: [OldFlag] -> IO () -oldRunit clis = do - 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 - - - - let fields = [ f | OF_Field f <- clis ] - - let auto_ghci_libs = any isAuto clis - where isAuto OF_AutoGHCiLibs = True; isAuto _ = False - input_file = my_head "inp" ([ f | (OF_Input f) <- clis] ++ ["-"]) - - force = if OF_Force `elem` clis then ForceAll else NoForce - - defines = [ (nm,val) | OF_DefinedName nm val <- clis ] - - case [ c | c <- clis, isAction c ] of - [ OF_List ] -> listPackages new_flags Nothing - [ OF_ListLocal ] -> listPackages new_flags Nothing - [ 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 - -- --------------------------------------------------------------------------- -- expanding environment variables in the package configuration -expandEnvVars :: String -> [(String, String)] -> Force -> IO String -expandEnvVars str defines force = go str "" +expandEnvVars :: String -> Force -> IO String +expandEnvVars str0 force = go str0 "" where go "" acc = return $! reverse acc go ('$':'{':str) acc | (var, '}':rest) <- break close str = do value <- lookupEnvVar var - go rest (reverse value ++ acc) - where close c = c == '}' || c == '\n' -- don't span newlines + go rest (reverse value ++ acc) + where close c = c == '}' || c == '\n' -- don't span newlines go (c:str) acc - = go str (c:acc) + = go str (c:acc) lookupEnvVar :: String -> IO String - lookupEnvVar nm = - case lookup nm defines of - Just x | not (null x) -> return x - _ -> - catch (System.getEnv nm) - (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++ - show nm) - return "") + lookupEnvVar nm = + catch (System.Environment.getEnv nm) + (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++ + show nm) + return "") ----------------------------------------------------------------------------- @@ -1010,130 +1143,225 @@ bye :: String -> IO a bye s = putStr s >> exitWith ExitSuccess die :: String -> IO a -die s = do +die = dieWith 1 + +dieWith :: Int -> String -> IO a +dieWith ec s = do hFlush stdout prog <- getProgramName hPutStrLn stderr (prog ++ ": " ++ s) - exitWith (ExitFailure 1) + exitWith (ExitFailure ec) dieOrForceAll :: Force -> String -> IO () dieOrForceAll ForceAll s = ignoreError s dieOrForceAll _other s = dieForcible s -dieOrForceFile :: Force -> String -> IO () -dieOrForceFile ForceAll s = ignoreError s -dieOrForceFile ForceFiles s = ignoreError s -dieOrForceFile _other s = dieForcible s - ignoreError :: String -> IO () -ignoreError s = do hFlush stdout; hPutStrLn stderr (s ++ " (ignoring)") +ignoreError s = reportError (s ++ " (ignoring)") + +reportError :: String -> IO () +reportError s = do hFlush stdout; hPutStrLn stderr s dieForcible :: String -> IO () dieForcible s = die (s ++ " (use --force to override)") +my_head :: String -> [a] -> a +my_head s [] = error s +my_head _ (x : _) = x + ----------------------------------------- --- Cut and pasted from ghc/compiler/SysTools +-- Cut and pasted from ghc/compiler/main/SysTools #if defined(mingw32_HOST_OS) +subst :: Char -> Char -> String -> String subst a b ls = map (\ x -> if x == a then b else x) ls + +unDosifyPath :: FilePath -> FilePath unDosifyPath xs = subst '\\' '/' xs -getExecDir :: String -> IO (Maybe String) +getLibDir :: IO (Maybe String) +getLibDir = fmap (fmap ( "lib")) $ getExecDir "/bin/ghc-pkg.exe" + -- (getExecDir cmd) returns the directory in which the current --- executable, which should be called 'cmd', is running +-- executable, which should be called 'cmd', is running -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd, -- you'll get "/a/b/c" back as the result -getExecDir cmd - = allocaArray len $ \buf -> do - ret <- getModuleFileName nullPtr buf len - if ret == 0 then return Nothing - else do s <- peekCString buf - return (Just (reverse (drop (length cmd) - (reverse (unDosifyPath s))))) - where - len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32. +getExecDir :: String -> IO (Maybe String) +getExecDir cmd = + getExecPath >>= maybe (return Nothing) removeCmdSuffix + where unDosifyPath = subst '\\' '/' + initN n = reverse . drop n . reverse + removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath + +getExecPath :: IO (Maybe String) +getExecPath = + allocaArray len $ \buf -> do + ret <- getModuleFileName nullPtr buf len + if ret == 0 then return Nothing + else liftM Just $ peekCString buf + where len = 2048 -- Plenty, PATH_MAX is 512 under Win32. + +foreign import stdcall unsafe "GetModuleFileNameA" + getModuleFileName :: Ptr () -> CString -> Int -> IO Int32 -foreign import stdcall unsafe "GetModuleFileNameA" - getModuleFileName :: Ptr () -> CString -> Int -> IO Int32 #else -getExecDir :: String -> IO (Maybe String) -getExecDir _ = return Nothing +getLibDir :: IO (Maybe String) +getLibDir = return Nothing #endif --- ----------------------------------------------------------------------------- --- FilePath utils +----------------------------------------- +-- Adapted from ghc/compiler/utils/Panic --- | 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 = '\\' +installSignalHandlers :: IO () +installSignalHandlers = do + threadid <- myThreadId + let + interrupt = Exception.throwTo threadid + (Exception.ErrorCall "interrupted") + -- +#if !defined(mingw32_HOST_OS) + installHandler sigQUIT (Catch interrupt) Nothing + installHandler sigINT (Catch interrupt) Nothing + return () +#elif __GLASGOW_HASKELL__ >= 603 + -- GHC 6.3+ has support for console events on Windows + -- NOTE: running GHCi under a bash shell for some reason requires + -- you to press Ctrl-Break rather than Ctrl-C to provoke + -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know + -- why --SDM 17/12/2004 + let sig_handler ControlC = interrupt + sig_handler Break = interrupt + sig_handler _ = return () + + installHandler (Catch sig_handler) + return () #else -pathSeparator = '/' + return () -- nothing #endif -getFilenameDir :: FilePath -> FilePath -getFilenameDir fn = case break isPathSeparator (reverse fn) of - (xs, "") -> "." - (_, sep:ys) -> reverse ys +#if __GLASGOW_HASKELL__ <= 604 +isInfixOf :: (Eq a) => [a] -> [a] -> Bool +isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) +#endif + +#if mingw32_HOST_OS || mingw32_TARGET_OS +throwIOIO :: Exception.IOException -> IO a +throwIOIO = Exception.throwIO + +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +catchIO = Exception.catch +#endif + +catchError :: IO a -> (String -> IO a) -> IO a +catchError io handler = io `Exception.catch` handler' + where handler' (Exception.ErrorCall err) = handler err + + +-- copied from Cabal's Distribution.Simple.Utils, except that we want +-- to use text files here, rather than binary files. +writeFileAtomic :: FilePath -> String -> IO () +writeFileAtomic targetFile content = do + (newFile, newHandle) <- openNewFile targetDir template + do hPutStr newHandle content + hClose newHandle +#if mingw32_HOST_OS || mingw32_TARGET_OS + renameFile newFile targetFile + -- If the targetFile exists then renameFile will fail + `catchIO` \err -> do + exists <- doesFileExist targetFile + if exists + then do removeFile targetFile + -- Big fat hairy race condition + renameFile newFile targetFile + -- If the removeFile succeeds and the renameFile fails + -- then we've lost the atomic property. + else throwIOIO err +#else + renameFile newFile targetFile +#endif + `Exception.onException` do hClose newHandle + removeFile newFile + where + template = targetName <.> "tmp" + targetDir | null targetDir_ = "." + | otherwise = targetDir_ + --TODO: remove this when takeDirectory/splitFileName is fixed + -- to always return a valid dir + (targetDir_,targetName) = splitFileName targetFile + +-- Ugh, this is a copy/paste of code from the base library, but +-- if uses 666 rather than 600 for the permissions. +openNewFile :: FilePath -> String -> IO (FilePath, Handle) +openNewFile dir template = do + pid <- c_getpid + findTempName pid + where + -- We split off the last extension, so we can use .foo.ext files + -- for temporary files (hidden on Unix OSes). Unfortunately we're + -- below filepath in the hierarchy here. + (prefix,suffix) = + case break (== '.') $ reverse template of + -- First case: template contains no '.'s. Just re-reverse it. + (rev_suffix, "") -> (reverse rev_suffix, "") + -- Second case: template contains at least one '.'. Strip the + -- dot from the prefix and prepend it to the suffix (if we don't + -- do this, the unique number will get added after the '.' and + -- thus be part of the extension, which is wrong.) + (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix) + -- Otherwise, something is wrong, because (break (== '.')) should + -- always return a pair with either the empty string or a string + -- beginning with '.' as the second component. + _ -> error "bug in System.IO.openTempFile" + + oflags = rw_flags .|. o_EXCL + + findTempName x = do + fd <- withCString filepath $ \ f -> + c_open f oflags 0o666 + if fd < 0 + then do + errno <- getErrno + if errno == eEXIST + then findTempName (x+1) + else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir)) + else do + -- XXX We want to tell fdToHandle what the filepath is, + -- as any exceptions etc will only be able to report the + -- fd currently + h <- +#if __GLASGOW_HASKELL__ >= 609 + fdToHandle fd +#else + fdToHandle (fromIntegral fd) +#endif + `Exception.onException` c_close fd + return (filepath, h) + where + filename = prefix ++ show x ++ suffix + filepath = dir `combine` filename + +-- XXX Copied from GHC.Handle +std_flags, output_flags, rw_flags :: CInt +std_flags = o_NONBLOCK .|. o_NOCTTY +output_flags = std_flags .|. o_CREAT +rw_flags = output_flags .|. o_RDWR -- | The function splits the given string to substrings --- using the 'searchPathSeparator'. +-- using 'isSearchPathSeparator'. parseSearchPath :: String -> [FilePath] parseSearchPath path = split path where split :: String -> [String] split s = case rest' of - [] -> [chunk] + [] -> [chunk] _:rest -> chunk : split rest where - chunk = + 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 - + (chunk', rest') = break isSearchPathSeparator s