X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=344a21edb89cd5278db8146a3496b270e5b1acfe;hb=e5e6f6a16796cba5e2b6bd376481cf2cd0ba9734;hp=bdd9c80893d28d56d97e1ab561ec8112b1b76d30;hpb=107e84293bb60b82233b1177eae66ed33b665af1;p=ghc-hetmet.git diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index bdd9c80..344a21e 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. @@ -16,20 +16,15 @@ module Main (main) where import Version ( version, targetOS, targetARCH ) -import Distribution.InstalledPackageInfo +import Distribution.InstalledPackageInfo hiding (depends) import Distribution.Compat.ReadP import Distribution.ParseUtils import Distribution.Package +import Distribution.Text import Distribution.Version import System.FilePath - -#ifdef USING_COMPAT -import Compat.Directory ( getAppUserDataDirectory, createDirectoryIfMissing ) -import Compat.RawSystem ( rawSystem ) -#else -import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing ) import System.Cmd ( rawSystem ) -#endif +import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing ) import Prelude @@ -42,24 +37,31 @@ import Data.Maybe import Data.Char ( isSpace, toLower ) import Control.Monad -import System.Directory ( doesDirectoryExist, getDirectoryContents, +import System.Directory ( doesDirectoryExist, getDirectoryContents, doesFileExist, renameFile, removeFile ) import System.Exit ( exitWith, ExitCode(..) ) import System.Environment ( getArgs, getProgName, getEnv ) import System.IO import System.IO.Error (try) -import Data.List ( isPrefixOf, isSuffixOf, intersperse, sortBy, nub ) +import Data.List import Control.Concurrent -#ifdef mingw32_HOST_OS import Foreign -import Foreign.C.String +import Foreign.C +#ifdef mingw32_HOST_OS import GHC.ConsoleHandler #else -import System.Posix +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 @@ -95,6 +97,8 @@ data Flag | FlagAutoGHCiLibs | FlagSimpleOutput | FlagNamesOnly + | FlagIgnoreCase + | FlagNoUserDb deriving Eq flags :: [OptDescr Flag] @@ -107,6 +111,8 @@ flags = [ "use the specified package config file", Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE") "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", Option [] ["force-files"] (NoArg FlagForceFiles) @@ -120,7 +126,9 @@ flags = [ Option [] ["simple-output"] (NoArg FlagSimpleOutput) "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" + "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] @@ -158,21 +166,36 @@ 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"++ @@ -198,6 +221,8 @@ substProg prog (c:xs) = c : substProg prog xs data Force = ForceAll | ForceFiles | NoForce +data PackageArg = Id PackageIdentifier | Substring String (String->Bool) + runit :: [Flag] -> [String] -> IO () runit cli nonopts = do installSignalHandlers -- catch ^C and clean up @@ -208,40 +233,85 @@ runit cli nonopts = do | FlagForceFiles `elem` cli = ForceFiles | otherwise = NoForce 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 +#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 + unregisterPackage pkgid cli force ["expose", pkgid_str] -> do pkgid <- readGlobPkgId pkgid_str - exposePackage pkgid cli + exposePackage pkgid cli force ["hide", pkgid_str] -> do pkgid <- readGlobPkgId pkgid_str - hidePackage pkgid cli + hidePackage pkgid cli force ["list"] -> do listPackages cli Nothing Nothing - ["list", pkgid_str] -> do - pkgid <- readGlobPkgId pkgid_str - listPackages cli (Just pkgid) 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 - listPackages cli Nothing (Just moduleName) + 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 + ["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 + + ["dump"] -> do + dumpPackages cli + [] -> do die ("missing command\n" ++ usageInfo (usageHeader prog) flags) @@ -260,9 +330,10 @@ readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier" parseGlobPackageId :: ReadP r PackageIdentifier parseGlobPackageId = - parsePackageId + parse +++ - (do n <- parsePackageName; string "-*" + (do n <- parse + string "-*" return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion })) -- globVersion means "all versions" @@ -284,23 +355,36 @@ globVersion = Version{ versionBranch=[], versionTags=["*"] } type PackageDBName = FilePath type PackageDB = [InstalledPackageInfo] -type PackageDBStack = [(PackageDBName,PackageDB)] +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. -getPkgDatabases :: Bool -> [Flag] -> IO PackageDBStack -getPkgDatabases modify flags = do +allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo] +allPackagesInStack = concatMap snd + +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 + case [ f | FlagGlobalConfig f <- my_flags ] of [] -> do mb_dir <- getExecDir "/bin/ghc-pkg.exe" case mb_dir of Nothing -> die err_msg - Just dir -> return (dir "package.conf") + Just dir -> + do let path1 = dir "package.conf" + path2 = dir ".." ".." ".." + "inplace-datadir" + "package.conf" + exists1 <- doesFileExist path1 + exists2 <- doesFileExist path2 + if exists1 then return path1 + else if exists2 then return path2 + else die "Can't find package.conf" fs -> return (last fs) let global_conf_dir = global_conf ++ ".d" @@ -313,19 +397,28 @@ 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.version - archdir = appdir subdir - user_conf = archdir "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] + | 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 (System.Environment.getEnv "GHC_PACKAGE_PATH") @@ -335,26 +428,28 @@ getPkgDatabases modify flags = do Right path | last cs == "" -> init cs ++ sys_databases | otherwise -> cs - where cs = splitSearchPath path + 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 - let db_flags = [ f | Just f <- map is_db_flag flags ] - where is_db_flag FlagUser = Just user_conf + 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 <- + (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 - else return (reverse (nub db_flags)) + 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 @@ -365,26 +460,26 @@ getPkgDatabases modify flags = do -- stack, unless any of them are present in the stack -- already. flag_stack = filter (`notElem` env_stack) - [ f | FlagConfig f <- reverse flags ] + [ f | FlagConfig f <- reverse my_flags ] ++ env_stack - 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.") + -- 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 - if null db_flags - then modifying virt_global_conf - else modifying (head db_flags) + return (flag_stack, to_modify) db_stack <- mapM readParseDatabase final_stack - return db_stack + return (db_stack, to_modify) readParseDatabase :: PackageDBName -> IO (PackageDBName,PackageDB) readParseDatabase filename = do - str <- readFile filename `Exception.catch` \_ -> return emptyPackageConfig - let packages = read str + str <- readFile filename `catchIO` \_ -> return emptyPackageConfig + let packages = map convertPackageInfoIn $ read str Exception.evaluate packages - `Exception.catch` \e-> + `catchError` \e-> die ("error while parsing " ++ filename ++ ": " ++ show e) return (filename,packages) @@ -400,13 +495,12 @@ registerPackage :: FilePath -> Bool -- update -> Force -> IO () -registerPackage input flags auto_ghci_libs update force = do - db_stack <- getPkgDatabases True flags +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 @@ -421,11 +515,13 @@ registerPackage input flags auto_ghci_libs update force = do pkg <- parsePackageInfo expanded putStrLn "done." - validatePackageConfig pkg db_stack auto_ghci_libs update force + 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 @@ -440,45 +536,61 @@ parsePackageInfo str = -- ----------------------------------------------------------------------------- -- 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 + 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 -> Maybe String -> IO () -listPackages flags mPackageName mModuleName = 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 - | Just this <- mModuleName = -- packages which expose mModuleName - map (\(conf,pkgs) -> (conf, filter (this `exposedInPkg`) pkgs)) + | Just match <- mModuleName = -- packages which expose mModuleName + map (\(conf,pkgs) -> (conf, filter (match `exposedInPkg`) pkgs)) db_stack | otherwise = db_stack @@ -492,7 +604,9 @@ listPackages flags mPackageName mModuleName = do EQ -> pkgVersion p1 `compare` pkgVersion p2 where (p1,p2) = (package pkg1, package pkg2) - pkg_map = map (\p -> (package p, p)) $ concatMap snd db_stack + 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) @@ -502,17 +616,18 @@ listPackages flags mPackageName mModuleName = do 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 - | isBrokenPackage p pkg_map = braces doc + | package p `elem` broken = braces doc | exposed p = doc | otherwise = parens doc - where doc = text (showPackageId (package p)) + where doc = text (display (package p)) show_simple db_stack = do - let showPkg = if FlagNamesOnly `elem` flags then pkgName - else showPackageId + let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName + else display pkgs = map showPkg $ sortBy compPkgIdVer $ - map package (concatMap snd db_stack) + map package (allPackagesInStack db_stack) when (not (null pkgs)) $ hPutStrLn stdout $ concat $ intersperse " " pkgs @@ -520,58 +635,77 @@ listPackages flags mPackageName mModuleName = do -- 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) +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 -exposedInPkg :: String -> InstalledPackageInfo -> Bool -moduleName `exposedInPkg` pkg = moduleName `elem` exposedModules pkg - -- ----------------------------------------------------------------------------- -- 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 = takeDirectory (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 strings "$topdir" and "$httptopdir" at the beginning of a path @@ -611,7 +745,7 @@ 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 @@ -626,86 +760,78 @@ strList = show -- Check: Check consistency of installed packages checkConsistency :: [Flag] -> IO () -checkConsistency flags = do - db_stack <- getPkgDatabases True flags +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 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 + let pkgs = allPackagesInStack db_stack + broken_pkgs = brokenPackages pkgs + broken_ids = map package broken_pkgs + broken_why = [ (package p, filter (`elem` broken_ids) (depends p)) + | p <- broken_pkgs ] + mapM_ (putStrLn . render . show_func) broken_why where - show_func | FlagSimpleOutput `elem` flags = show_simple + show_func | FlagSimpleOutput `elem` my_flags = show_simple | otherwise = show_normal show_simple (pid,deps) = - text (showPackageId pid) <> colon - <+> fsep (punctuate comma (map (text . showPackageId) deps)) + text (display pid) <> colon + <+> fsep (punctuate comma (map (text . display) deps)) show_normal (pid,deps) = - text "package" <+> text (showPackageId pid) <+> text "has missing dependencies:" - $$ nest 4 (fsep (punctuate comma (map (text . showPackageId) deps))) + text "package" <+> text (display pid) <+> text "has missing dependencies:" + $$ nest 4 (fsep (punctuate comma (map (text . display) 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 +brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo] +brokenPackages pkgs = go [] pkgs + where + go avail not_avail = + case partition (depsAvailable avail) not_avail of + ([], not_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) -- ----------------------------------------------------------------------------- -- 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 $ takeDirectory filename - h <- openFile filename WriteMode `catch` \e -> + 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 - let shown = concat $ intersperse ",\n " $ map show packages - fileContents = "[" ++ shown ++ "\n]" - hPutStrLn h fileContents - 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 - (do hPutStrLn stdout "done."; io) - `Exception.catch` \e -> do - hPutStr stdout ("WARNING: an error was encountered while writing " - ++ "the new configuration.\n") - if restore_on_error - then do - hPutStr stdout "Attempting to restore the old configuration... " - do renameFile oldFile filename - hPutStrLn stdout "done." - `catch` \err -> hPutStrLn stdout ("Failed: " ++ show err) - else do - -- file did not exist before, so the new one which - -- might be partially complete. - try (removeFile filename) - return () - Exception.throwIO e - ----------------------------------------------------------------------------- -- Sanity-check a new package config, and automatically build GHCi libs -- if requested. @@ -720,6 +846,7 @@ validatePackageConfig pkg db_stack auto_ghci_libs update force = do checkPackageId pkg checkDuplicates db_stack pkg update force mapM_ (checkDep db_stack force) (depends pkg) + checkDuplicateDepends force (depends pkg) mapM_ (checkDir force) (importDirs pkg) mapM_ (checkDir force) (libraryDirs pkg) mapM_ (checkDir force) (includeDirs pkg) @@ -734,8 +861,8 @@ validatePackageConfig pkg db_stack auto_ghci_libs update force = do -- 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 + 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) @@ -749,16 +876,16 @@ checkDuplicates db_stack pkg update force = do -- 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") + die ("package " ++ display pkgid ++ " is already installed") let - uncasep = map toLower . showPackageId + uncasep = map toLower . display dups = filter ((== uncasep pkgid) . uncasep) (map package pkgs) when (not update && not (null dups)) $ dieOrForceAll force $ "Package names may be treated case-insensitively in the future.\n"++ - "Package " ++ showPackageId pkgid ++ - " overlaps with: " ++ unwords (map showPackageId dups) + "Package " ++ display pkgid ++ + " overlaps with: " ++ unwords (map display dups) checkDir :: Force -> String -> IO () @@ -774,7 +901,7 @@ checkDir force d checkDep :: PackageDBStack -> Force -> PackageIdentifier -> IO () checkDep db_stack force pkgid | pkgid `elem` pkgids || (not real_version && name_exists) = return () - | otherwise = dieOrForceAll force ("dependency " ++ showPackageId pkgid + | otherwise = dieOrForceAll force ("dependency " ++ display pkgid ++ " doesn't exist") where -- for backwards compat, we treat 0.0 as a special version, @@ -784,9 +911,17 @@ checkDep db_stack force pkgid name_exists = any (\p -> pkgName (package p) == name) all_pkgs name = pkgName pkgid - all_pkgs = concat (map snd db_stack) + all_pkgs = allPackagesInStack db_stack pkgids = map package all_pkgs +checkDuplicateDepends :: Force -> [PackageIdentifier] -> IO () +checkDuplicateDepends force deps + | null dups = return () + | otherwise = dieOrForceAll force ("package has duplicate dependencies: " ++ + unwords (map display dups)) + where + dups = [ p | (p:_:_) <- group (sort deps) ] + realVersion :: PackageIdentifier -> Bool realVersion pkgid = versionBranch (pkgVersion pkgid) /= [] @@ -877,7 +1012,7 @@ okInModuleName c -- expanding environment variables in the package configuration expandEnvVars :: String -> Force -> IO String -expandEnvVars str force = go str "" +expandEnvVars str0 force = go str0 "" where go "" acc = return $! reverse acc go ('$':'{':str) acc | (var, '}':rest) <- break close str @@ -906,11 +1041,14 @@ 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 @@ -928,8 +1066,8 @@ dieForcible :: String -> IO () dieForcible s = die (s ++ " (use --force to override)") my_head :: String -> [a] -> a -my_head s [] = error s -my_head s (x:xs) = x +my_head s [] = error s +my_head _ (x : _) = x ----------------------------------------- -- Cut and pasted from ghc/compiler/main/SysTools @@ -991,3 +1129,154 @@ installSignalHandlers = do #else return () -- nothing #endif + +#if __GLASGOW_HASKELL__ <= 604 +isInfixOf :: (Eq a) => [a] -> [a] -> Bool +isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) +#endif + +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#if __GLASGOW_HASKELL__ >= 609 +catchIO = Exception.catch +#else +catchIO io handler = io `Exception.catch` handler' + where handler' (Exception.IOException ioe) = handler ioe + handler' e = Exception.throw e +#endif + +#if mingw32_HOST_OS || mingw32_TARGET_OS +throwIOIO :: Exception.IOException -> IO a +#if __GLASGOW_HASKELL__ >= 609 +throwIOIO = Exception.throwIO +#else +throwIOIO ioe = Exception.throwIO (Exception.IOException ioe) +#endif +#endif + +catchError :: IO a -> (String -> IO a) -> IO a +#if __GLASGOW_HASKELL__ >= 609 +catchError io handler = io `Exception.catch` handler' + where handler' (Exception.ErrorCall err) = handler err +#else +catchError io handler = io `Exception.catch` handler' + where handler' (Exception.ErrorCall err) = handler err + handler' e = Exception.throw e +#endif + +onException :: IO a -> IO b -> IO a +#if __GLASGOW_HASKELL__ >= 609 +onException = Exception.onException +#else +onException io what = io `Exception.catch` \e -> do what + Exception.throw e +#endif + + +-- 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 + `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 + `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 'isSearchPathSeparator'. +parseSearchPath :: String -> [FilePath] +parseSearchPath path = split path + where + split :: String -> [String] + split s = + case rest' of + [] -> [chunk] + _:rest -> chunk : split rest + where + chunk = + case chunk' of +#ifdef mingw32_HOST_OS + ('\"':xs@(_:_)) | last xs == '\"' -> init xs +#endif + _ -> chunk' + + (chunk', rest') = break isSearchPathSeparator s