X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=a9cb9f3c68b8bfce49c365bc2c8fefafeb9a5924;hb=c9e8286bf57931bd9daa0135326a7857c2351d03;hp=7f727d7966496db668b09bbaf2a8f62cdfe27098;hpb=eed437cdefb952e6c70e58012b23d436e74710af;p=ghc-hetmet.git diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 7f727d7..a9cb9f3 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -44,7 +44,7 @@ import System.Environment ( getArgs, getProgName, getEnv ) import System.IO import System.IO.Error (try) import Data.List ( isPrefixOf, isSuffixOf, intersperse, sortBy, nub, - unfoldr, break ) + unfoldr, break, partition ) #if __GLASGOW_HASKELL__ > 604 import Data.List ( isInfixOf ) #else @@ -102,6 +102,7 @@ data Flag | FlagSimpleOutput | FlagNamesOnly | FlagIgnoreCase + | FlagNoUserDb deriving Eq flags :: [OptDescr Flag] @@ -114,6 +115,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) @@ -276,13 +279,13 @@ runit cli nonopts = do 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] -> @@ -356,14 +359,15 @@ 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. allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo] allPackagesInStack = concatMap snd -getPkgDatabases :: Bool -> [Flag] -> IO PackageDBStack +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 @@ -375,7 +379,16 @@ getPkgDatabases modify my_flags = do [] -> 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" @@ -388,19 +401,28 @@ getPkgDatabases modify my_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 ex -> + 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") @@ -417,19 +439,21 @@ getPkgDatabases modify my_flags = do virt_global_conf = last env_stack let db_flags = [ f | Just f <- map is_db_flag my_flags ] - where is_db_flag FlagUser = Just user_conf + 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 @@ -443,23 +467,23 @@ getPkgDatabases modify my_flags = do [ 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 + 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) @@ -476,12 +500,11 @@ registerPackage :: FilePath -> Force -> IO () registerPackage input my_flags auto_ghci_libs update force = do - db_stack <- getPkgDatabases True my_flags + (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 @@ -496,11 +519,13 @@ registerPackage input my_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 @@ -515,31 +540,46 @@ 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 :: PackageIdentifier -> [Flag] -> Force -> IO () unregisterPackage = modifyPackage (\_ -> []) modifyPackage :: (InstalledPackageInfo -> [InstalledPackageInfo]) -> PackageIdentifier -> [Flag] + -> Force -> IO () -modifyPackage fn pkgid my_flags = do - db_stack <- getPkgDatabases True{-modify-} my_flags - let ((db_name, pkgs) : _) = db_stack - ps <- findPackages [(db_name,pkgs)] (Id 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,pkgs) | (nm,pkgs) <- 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 @@ -547,7 +587,7 @@ modifyPackage fn pkgid my_flags = do 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 + (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)) @@ -569,7 +609,7 @@ listPackages my_flags mPackageName mModuleName = do match `exposedInPkg` pkg = any match (map display $ exposedModules pkg) - pkg_map = map (\p -> (package p, p)) $ allPackagesInStack db_stack + 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) @@ -579,8 +619,9 @@ listPackages my_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 (display (package p)) @@ -598,7 +639,7 @@ listPackages my_flags mPackageName mModuleName = do latestPackage :: [Flag] -> PackageIdentifier -> IO () latestPackage my_flags pkgid = do - db_stack <- getPkgDatabases False my_flags + (db_stack, _) <- getPkgDatabases False my_flags ps <- findPackages db_stack (Id pkgid) show_pkg (sortBy compPkgIdVer (map package ps)) where @@ -610,13 +651,13 @@ latestPackage my_flags pkgid = do describePackage :: [Flag] -> PackageArg -> IO () describePackage my_flags pkgarg = do - db_stack <- getPkgDatabases False my_flags + (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 + (db_stack, _) <- getPkgDatabases False my_flags doDump (allPackagesInStack db_stack) doDump :: [InstalledPackageInfo] -> IO () @@ -625,13 +666,20 @@ doDump = mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo -- PackageId is can have globVersion for the version findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo] findPackages db_stack pkgarg - = case [ p | p <- all_pkgs, pkgarg `matchesPkg` p ] of - [] -> die ("cannot find package " ++ pkg_msg pkgarg) + = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg + +findPackagesByDB :: PackageDBStack -> PackageArg + -> IO [(NamedPackageDB, [InstalledPackageInfo])] +findPackagesByDB db_stack pkgarg + = case [ (db, matched) + | db@(db_name,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 = allPackagesInStack db_stack pkg_msg (Id pkgid) = display pkgid - pkg_msg (Substring pkgpat _) = "matching "++pkgpat + pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat matches :: PackageIdentifier -> PackageIdentifier -> Bool pid `matches` pid' @@ -650,7 +698,7 @@ compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2 describeField :: [Flag] -> PackageArg -> [String] -> IO () describeField my_flags pkgarg fields = do - db_stack <- getPkgDatabases False my_flags + (db_stack, _) <- getPkgDatabases False my_flags fns <- toFields fields ps <- findPackages db_stack pkgarg let top_dir = takeDirectory (fst (last db_stack)) @@ -716,16 +764,15 @@ strList = show checkConsistency :: [Flag] -> IO () checkConsistency my_flags = do - db_stack <- getPkgDatabases True my_flags + (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)) $ allPackagesInStack 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` my_flags = show_simple | otherwise = show_normal @@ -736,20 +783,22 @@ checkConsistency my_flags = do 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 (filter notme pkg_map) - where notme (p, _ipi) = package pkg /= p - -- remove p from the database when we invoke missingPackageDeps, - -- because we want mutually recursive groups of package to show up + +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) -- ----------------------------------------------------------------------------- @@ -776,47 +825,16 @@ 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 -> - 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 . convertPackageInfoOut) packages fileContents = "[" ++ shown ++ "\n]" - hPutStrLn h fileContents - hClose h + writeFileAtomic filename fileContents + `catch` \e -> + if isPermissionError e + then die (filename ++ ": you don't have permission to modify this file") + else ioError e 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") - -- remove any partially complete new version: - try (removeFile filename) - -- and attempt to restore the old one, if we had one: - 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) - -- Note the above renameFile sometimes fails on Windows with - -- "permission denied", I have no idea why --SDM. - Exception.throwIO e - ----------------------------------------------------------------------------- -- Sanity-check a new package config, and automatically build GHCi libs -- if requested. @@ -1017,11 +1035,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 @@ -1107,3 +1128,70 @@ installSignalHandlers = do 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 + +throwIOIO :: Exception.IOException -> IO a +#if __GLASGOW_HASKELL__ >= 609 +throwIOIO = Exception.throwIO +#else +throwIOIO ioe = Exception.throwIO (Exception.IOException ioe) +#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 () -> 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 + (tmpFile, tmpHandle) <- openTempFile targetDir template + do hPutStr tmpHandle content + hClose tmpHandle +#if mingw32_HOST_OS || mingw32_TARGET_OS + renameFile tmpFile 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 tmpFile targetFile + -- If the removeFile succeeds and the renameFile fails + -- then we've lost the atomic property. + else throwIOIO err +#else + renameFile tmpFile targetFile +#endif + `onException` do hClose tmpHandle + removeFile tmpFile + 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