X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=414ec37f4feab83e25d79487086f20a5dddea5a1;hb=4bd1e966ffb4985f180e9728328ff7e3e7b37bb1;hp=3b0b4385df83ccc7df329a45539aaa9b62b76eb3;hpb=cf81f273637efb4e2199493814ca57d9d447f839;p=ghc-hetmet.git diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 3b0b438..414ec37 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -52,7 +52,7 @@ import System.IO.Error (try) #else import System.IO (try) #endif -import Data.List ( isPrefixOf, isSuffixOf, intersperse, groupBy, sortBy ) +import Data.List ( isPrefixOf, isSuffixOf, intersperse, sortBy ) #ifdef mingw32_HOST_OS import Foreign @@ -64,6 +64,8 @@ import CString #endif #endif +import IO ( isPermissionError, isDoesNotExistError ) + -- ----------------------------------------------------------------------------- -- Entry point @@ -104,6 +106,7 @@ data Flag | FlagConfig FilePath | FlagGlobalConfig FilePath | FlagForce + | FlagForceFiles | FlagAutoGHCiLibs | FlagDefinedName String String | FlagSimpleOutput @@ -121,6 +124,8 @@ flags = [ "location of the global package config", Option [] ["force"] (NoArg FlagForce) "ignore missing dependencies, directories, and libraries", + Option [] ["force-files"] (NoArg FlagForceFiles) + "ignore missing directories and libraries only", Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs) "automatically build libs for GHCi (with register)", Option ['?'] ["help"] (NoArg FlagHelp) @@ -130,7 +135,7 @@ flags = [ Option ['V'] ["version"] (NoArg FlagVersion) "output version information and exit", Option [] ["simple-output"] (NoArg FlagSimpleOutput) - "print output in easy-to-parse format when running command 'list'" + "print output in easy-to-parse format for some commands" ] where toDefined str = @@ -166,10 +171,15 @@ usageHeader prog = substProg prog $ " List registered packages in the global database, and also the\n" ++ " user database if --user is given. If a package name is given\n" ++ " all the registered versions will be listed in ascending order.\n" ++ + " Accepts the --simple-output flag.\n" ++ "\n" ++ " $p latest pkg\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" ++ " Give the registered description for the specified package. The\n" ++ " description is returned in precisely the syntax required by $p\n" ++ @@ -189,11 +199,16 @@ substProg prog (c:xs) = c : substProg prog xs -- ----------------------------------------------------------------------------- -- Do the business +data Force = ForceAll | ForceFiles | NoForce + runit :: [Flag] -> [String] -> IO () runit cli nonopts = do prog <- getProgramName let - force = FlagForce `elem` cli + force + | FlagForce `elem` cli = ForceAll + | FlagForceFiles `elem` cli = ForceFiles + | otherwise = NoForce auto_ghci_libs = FlagAutoGHCiLibs `elem` cli defines = [ (nm,val) | FlagDefinedName nm val <- cli ] -- @@ -226,6 +241,8 @@ runit cli nonopts = do ["field", pkgid_str, field] -> do pkgid <- readGlobPkgId pkgid_str describeField cli pkgid field + ["check"] -> do + checkConsistency cli [] -> do die ("missing command\n" ++ usageInfo (usageHeader prog) flags) @@ -375,7 +392,7 @@ registerPackage :: FilePath -> [Flag] -> Bool -- auto_ghci_libs -> Bool -- update - -> Bool -- force + -> Force -> IO () registerPackage input defines flags auto_ghci_libs update force = do db_stack <- getPkgDatabases True flags @@ -383,7 +400,6 @@ registerPackage input defines flags auto_ghci_libs update force = do db_to_operate_on = my_head "db" db_stack db_filename = fst db_to_operate_on -- - checkConfigAccess db_filename s <- case input of @@ -396,22 +412,21 @@ registerPackage input defines flags auto_ghci_libs update force = do expanded <- expandEnvVars s defines force - pkg0 <- parsePackageInfo expanded defines force + pkg0 <- parsePackageInfo expanded defines putStrLn "done." let pkg = resolveDeps db_stack pkg0 - overlaps <- validatePackageConfig pkg db_stack auto_ghci_libs update force - new_details <- updatePackageDB db_stack overlaps (snd db_to_operate_on) pkg - savePackageConfig db_filename - maybeRestoreOldConfig db_filename $ + validatePackageConfig pkg db_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 parsePackageInfo :: String -> [(String,String)] - -> Bool -> IO InstalledPackageInfo -parsePackageInfo str defines force = +parsePackageInfo str defines = case parseInstalledPackageInfo str of ParseOk _warns ok -> return ok ParseFailed err -> die (showError err) @@ -436,15 +451,13 @@ modifyPackage modifyPackage fn pkgid flags = do db_stack <- getPkgDatabases True{-modify-} flags let ((db_name, pkgs) : _) = db_stack - checkConfigAccess db_name ps <- findPackages [(db_name,pkgs)] pkgid let pids = map package ps - savePackageConfig db_name let new_config = concat (map modify pkgs) modify pkg | package pkg `elem` pids = fn pkg | otherwise = [pkg] - maybeRestoreOldConfig db_name $ + savingOldConfig db_name $ writeNewConfig db_name new_config -- ----------------------------------------------------------------------------- @@ -470,21 +483,23 @@ listPackages flags mPackageName = do EQ -> pkgVersion p1 `compare` pkgVersion p2 where (p1,p2) = (package pkg1, package pkg2) - show_func = if simple_output then show_easy else mapM_ show_regular + pkg_map = map (\p -> (package p, p)) $ concatMap snd db_stack + show_func = if simple_output then show_simple else mapM_ (show_normal pkg_map) show_func (reverse db_stack_sorted) - where show_regular (db_name,pkg_confs) = + where show_normal pkg_map (db_name,pkg_confs) = hPutStrLn stdout (render $ - text (db_name ++ ":") $$ nest 4 packages + 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_easy db_stack = do + show_simple db_stack = do let pkgs = map showPackageId $ sortBy compPkgIdVer $ map package (concatMap snd db_stack) when (null pkgs) $ die "no matches" @@ -562,52 +577,81 @@ toField s = showInstalledPackageInfoField s strList :: [String] -> String strList = show + -- ----------------------------------------------------------------------------- --- Manipulating package.conf files +-- Check: Check consistency of installed packages -checkConfigAccess :: FilePath -> IO () -checkConfigAccess filename = do - access <- getPermissions filename - when (not (writable access)) - (die (filename ++ ": you don't have permission to modify this file")) - -maybeRestoreOldConfig :: FilePath -> IO () -> IO () -maybeRestoreOldConfig filename io - = io `catch` \e -> do - hPutStrLn stderr (show e) - hPutStr stdout ("\nWARNING: an error was encountered while the new \n"++ - "configuration was being written. Attempting to \n"++ - "restore the old configuration... ") - renameFile (filename ++ ".old") filename - hPutStrLn stdout "done." - ioError e +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 + + +-- ----------------------------------------------------------------------------- +-- Manipulating package.conf files writeNewConfig :: FilePath -> [InstalledPackageInfo] -> IO () writeNewConfig filename packages = do hPutStr stdout "Writing new package config file... " - h <- openFile filename WriteMode + createDirectoryIfMissing True $ getFilenameDir 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 hPutStrLn h (show packages) hClose h hPutStrLn stdout "done." -savePackageConfig :: FilePath -> IO () -savePackageConfig filename = do +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" - doesExist <- doesFileExist oldFile `catch` (\ _ -> return False) - when doesExist (removeFile oldFile `catch` (const $ return ())) - catch (renameFile filename oldFile) - (\ err -> do - hPutStrLn stderr (unwords [ "Unable to rename " - , show filename - , " to " - , show oldFile - ]) - ioError err) + 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 @@ -617,17 +661,16 @@ validatePackageConfig :: InstalledPackageInfo -> PackageDBStack -> Bool -- auto-ghc-libs -> Bool -- update - -> Bool -- force - -> IO [PackageIdentifier] + -> Force + -> IO () validatePackageConfig pkg db_stack auto_ghci_libs update force = do checkPackageId pkg - overlaps <- checkDuplicates db_stack pkg update force + 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) - return overlaps -- ToDo: check these somehow? -- extra_libraries :: [String], -- c_includes :: [String], @@ -670,9 +713,8 @@ resolveDeps db_stack p = updateDeps p [] -> dep_pkgid -- No installed package; use -- the version-less one -checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Bool - -> IO [PackageIdentifier] -checkDuplicates db_stack pkg update force = do +checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> IO () +checkDuplicates db_stack pkg update = do let pkgid = package pkg (_top_db_name, pkgs) : _ = db_stack @@ -682,136 +724,42 @@ checkDuplicates db_stack pkg update force = do when (not update && (pkgid `elem` map package pkgs)) $ die ("package " ++ showPackageId pkgid ++ " is already installed") - -- - -- Check whether any of the dependencies of the current package - -- conflict with each other. - -- - let - all_pkgs = concat (map snd db_stack) - - allModules p = exposedModules p ++ hiddenModules p - - our_dependencies = closePackageDeps all_pkgs [pkg] - all_dep_modules = concat (map (\p -> zip (allModules p) (repeat p)) - our_dependencies) - - overlaps = [ (m, map snd group) - | group@((m,_):_) <- groupBy eqfst (sortBy cmpfst all_dep_modules), - length group > 1 ] - where eqfst (a,_) (b,_) = a == b - cmpfst (a,_) (b,_) = a `compare` b - - when (not (null overlaps)) $ - diePrettyOrForce force $ vcat [ - text "package" <+> text (showPackageId (package pkg)) <+> - text "has conflicting dependencies:", - let complain_about (mod,ps) = - text mod <+> text "is in the following packages:" <+> - sep (map (text.showPackageId.package) ps) - in - nest 3 (vcat (map complain_about overlaps)) - ] - - -- - -- Now check whether exposing this package will result in conflicts, and - -- Figure out which packages we need to hide to resolve the conflicts. - -- - let - closure_exposed_pkgs = closePackageDeps pkgs (filter exposed pkgs) - - new_dep_modules = concat $ map allModules $ - filter (\p -> package p `notElem` - map package closure_exposed_pkgs) $ - our_dependencies - - pkgs_with_overlapping_modules = - [ (p, overlapping_mods) - | p <- closure_exposed_pkgs, - let overlapping_mods = - filter (`elem` new_dep_modules) (allModules p), - (_:_) <- [overlapping_mods] --trick to get the non-empty ones - ] - - to_hide = map package - $ filter exposed - $ closePackageDepsUpward pkgs - $ map fst pkgs_with_overlapping_modules - - when (not update && exposed pkg && not (null pkgs_with_overlapping_modules)) $ do - diePretty $ vcat [ - text "package" <+> text (showPackageId (package pkg)) <+> - text "conflicts with the following packages, which are", - text "either exposed or a dependency (direct or indirect) of an exposed package:", - let complain_about (p, mods) - = text (showPackageId (package p)) <+> text "contains modules" <+> - sep (punctuate comma (map text mods)) in - nest 3 (vcat (map complain_about pkgs_with_overlapping_modules)), - text "Using 'update' instead of 'register' will cause the following packages", - text "to be hidden, which will eliminate the conflict:", - nest 3 (sep (map (text.showPackageId) to_hide)) - ] - - when (not (null to_hide)) $ do - hPutStrLn stderr $ render $ - sep [text "Warning: hiding the following packages to avoid conflict: ", - nest 2 (sep (map (text.showPackageId) to_hide))] - - return to_hide - - -closure :: (a->[a]->Bool) -> (a -> [a]) -> [a] -> [a] -> [a] -closure pred more [] res = res -closure pred more (p:ps) res - | p `pred` res = closure pred more ps res - | otherwise = closure pred more (more p ++ ps) (p:res) - -closePackageDeps :: [InstalledPackageInfo] -> [InstalledPackageInfo] - -> [InstalledPackageInfo] -closePackageDeps db start - = closure (\p ps -> package p `elem` map package ps) getDepends start [] - where - getDepends p = [ pkg | dep <- depends p, pkg <- lookupPkg dep ] - lookupPkg p = [ q | q <- db, p == package q ] - -closePackageDepsUpward :: [InstalledPackageInfo] -> [InstalledPackageInfo] - -> [InstalledPackageInfo] -closePackageDepsUpward db start - = closure (\p ps -> package p `elem` map package ps) getUpwardDepends start [] - where - getUpwardDepends p = [ pkg | pkg <- db, package p `elem` depends pkg ] -checkDir :: Bool -> String -> IO () +checkDir :: Force -> String -> IO () checkDir force d | "$topdir" `isPrefixOf` d = return () -- can't check this, because we don't know what $topdir is | otherwise = do there <- doesDirectoryExist d when (not there) - (dieOrForce force (d ++ " doesn't exist or isn't a directory")) + (dieOrForceFile force (d ++ " doesn't exist or isn't a directory")) -checkDep :: PackageDBStack -> Bool -> PackageIdentifier -> IO () +checkDep :: PackageDBStack -> Force -> PackageIdentifier -> IO () checkDep db_stack force pkgid - | not real_version || pkgid `elem` pkgids = return () - | otherwise = dieOrForce force ("dependency " ++ showPackageId pkgid + | pkgid `elem` pkgids || (not real_version && name_exists) = return () + | otherwise = dieOrForceAll force ("dependency " ++ showPackageId 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 + 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 realVersion :: PackageIdentifier -> Bool realVersion pkgid = versionBranch (pkgVersion pkgid) /= [] -checkHSLib :: [String] -> Bool -> Bool -> String -> IO () +checkHSLib :: [String] -> Bool -> Force -> String -> IO () checkHSLib dirs auto_ghci_libs force lib = do let batch_lib_file = "lib" ++ lib ++ ".a" bs <- mapM (doesLibExistIn batch_lib_file) dirs case [ dir | (exists,dir) <- zip bs dirs, exists ] of - [] -> dieOrForce force ("cannot find " ++ batch_lib_file ++ + [] -> dieOrForceFile force ("cannot find " ++ batch_lib_file ++ " on library path") (dir:_) -> checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs @@ -851,30 +799,6 @@ autoBuildGHCiLib dir batch_file ghci_file = do hPutStrLn stderr (" done.") -- ----------------------------------------------------------------------------- --- Updating the DB with the new package. - -updatePackageDB - :: PackageDBStack -- the full stack - -> [PackageIdentifier] -- packages to hide - -> [InstalledPackageInfo] -- packages in *this* DB - -> InstalledPackageInfo -- the new package - -> IO [InstalledPackageInfo] -updatePackageDB db_stack to_hide pkgs new_pkg = do - let - pkgid = package new_pkg - - pkgs' = [ maybe_hide p | p <- pkgs, package p /= pkgid ] - - -- When update is on, and we're exposing the new package, - -- we hide any packages which conflict (see checkDuplicates) - -- in the current DB. - maybe_hide p - | exposed new_pkg && package p `elem` to_hide = p{ exposed = False } - | otherwise = p - -- - return (pkgs'++ [new_pkg]) - --- ----------------------------------------------------------------------------- -- Searching for modules #if not_yet @@ -988,7 +912,7 @@ oldRunit clis = do where isAuto OF_AutoGHCiLibs = True; isAuto _ = False input_file = my_head "inp" ([ f | (OF_Input f) <- clis] ++ ["-"]) - force = OF_Force `elem` clis + force = if OF_Force `elem` clis then ForceAll else NoForce defines = [ (nm,val) | OF_DefinedName nm val <- clis ] @@ -1018,7 +942,7 @@ my_head s (x:xs) = x -- --------------------------------------------------------------------------- -- expanding environment variables in the package configuration -expandEnvVars :: String -> [(String, String)] -> Bool -> IO String +expandEnvVars :: String -> [(String, String)] -> Force -> IO String expandEnvVars str defines force = go str "" where go "" acc = return $! reverse acc @@ -1035,7 +959,7 @@ expandEnvVars str defines force = go str "" Just x | not (null x) -> return x _ -> catch (System.getEnv nm) - (\ _ -> do dieOrForce force ("Unable to expand variable " ++ + (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++ show nm) return "") @@ -1057,22 +981,20 @@ die s = do hPutStrLn stderr (prog ++ ": " ++ s) exitWith (ExitFailure 1) -dieOrForce :: Bool -> String -> IO () -dieOrForce force s - | force = do hFlush stdout; hPutStrLn stderr (s ++ " (ignoring)") - | otherwise = die (s ++ " (use --force to override)") +dieOrForceAll :: Force -> String -> IO () +dieOrForceAll ForceAll s = ignoreError s +dieOrForceAll _other s = dieForcible s -diePretty :: Doc -> IO () -diePretty doc = do - hFlush stdout - prog <- getProgramName - hPutStrLn stderr $ render $ (text prog <> colon $$ nest 2 doc) - exitWith (ExitFailure 1) +dieOrForceFile :: Force -> String -> IO () +dieOrForceFile ForceAll s = ignoreError s +dieOrForceFile ForceFiles s = ignoreError s +dieOrForceFile _other s = dieForcible s -diePrettyOrForce :: Bool -> Doc -> IO () -diePrettyOrForce force doc - | force = do hFlush stdout; hPutStrLn stderr (render (doc $$ text "(ignoring)")) - | otherwise = diePretty (doc $$ text "(use --force to override)") +ignoreError :: String -> IO () +ignoreError s = do hFlush stdout; hPutStrLn stderr (s ++ " (ignoring)") + +dieForcible :: String -> IO () +dieForcible s = die (s ++ " (use --force to override)") ----------------------------------------- -- Cut and pasted from ghc/compiler/SysTools @@ -1145,6 +1067,11 @@ pathSeparator = '\\' pathSeparator = '/' #endif +getFilenameDir :: FilePath -> FilePath +getFilenameDir fn = case break isPathSeparator (reverse fn) of + (xs, "") -> "." + (_, sep:ys) -> reverse ys + -- | The function splits the given string to substrings -- using the 'searchPathSeparator'. parseSearchPath :: String -> [FilePath]