X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=4b376848afa4649a8070161aff71691de709110a;hb=430453c5131592b6147a80202dc5f7fbe3f3d5fd;hp=b2f7d1833cf66035d1b73f9a6c4c1a5ffbae2bdb;hpb=be826f7c126244ba40252ed8b774c6aca8135422;p=ghc-hetmet.git diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index b2f7d18..4b37684 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -18,28 +18,26 @@ module Main (main) where import Version ( version, targetOS, targetARCH ) import Distribution.InstalledPackageInfo import Distribution.Compat.ReadP -import Distribution.ParseUtils ( showError ) +import Distribution.ParseUtils import Distribution.Package import Distribution.Version -import Compat.Directory ( getAppUserDataDirectory, createDirectoryIfMissing ) -import Compat.RawSystem ( rawSystem ) + +#ifdef USING_COMPAT +import Compat.Directory ( getAppUserDataDirectory, createDirectoryIfMissing ) +import Compat.RawSystem ( rawSystem ) +#else +import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing ) +import System.Cmd ( rawSystem ) +#endif import Prelude #include "../../includes/ghcconfig.h" -#if __GLASGOW_HASKELL__ >= 504 import System.Console.GetOpt import Text.PrettyPrint import qualified Control.Exception as Exception import Data.Maybe -#else -import GetOpt -import Pretty -import qualified Exception -import Maybe -#endif - import Data.Char ( isSpace ) import Monad import Directory @@ -47,23 +45,16 @@ import System ( getArgs, getProgName, getEnv, exitWith, ExitCode(..) ) 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 ) #ifdef mingw32_HOST_OS import Foreign - -#if __GLASGOW_HASKELL__ >= 504 import Foreign.C.String -#else -import CString -#endif #endif +import IO ( isPermissionError, isDoesNotExistError ) + -- ----------------------------------------------------------------------------- -- Entry point @@ -104,6 +95,7 @@ data Flag | FlagConfig FilePath | FlagGlobalConfig FilePath | FlagForce + | FlagForceFiles | FlagAutoGHCiLibs | FlagDefinedName String String | FlagSimpleOutput @@ -121,6 +113,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 +124,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 +160,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 +188,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 +230,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 +381,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 +389,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,26 +401,26 @@ 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 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 - savePackageConfig db_filename - maybeRestoreOldConfig db_filename $ + 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) + ParseFailed err -> case locatedErrorMsg err of + (Nothing, s) -> die s + (Just l, s) -> die (show l ++ ": " ++ s) -- ----------------------------------------------------------------------------- -- Exposing, Hiding, Unregistering are all similar @@ -437,15 +442,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 -- ----------------------------------------------------------------------------- @@ -471,21 +474,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" @@ -542,7 +547,34 @@ describeField flags pkgid field = do Nothing -> die ("unknown field: " ++ field) Just fn -> do ps <- findPackages db_stack pkgid - mapM_ (putStrLn.fn) ps + let top_dir = getFilenameDir (fst (last db_stack)) + mapM_ (putStrLn . fn) (mungePackagePaths top_dir ps) + +mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo] +-- Replace the string "$topdir" 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) + } + + munge_paths = map munge_path + + munge_path p + | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p' + | otherwise = p + +maybePrefixMatch :: String -> String -> Maybe String +maybePrefixMatch [] rest = Just rest +maybePrefixMatch (_:_) [] = Nothing +maybePrefixMatch (p:pat) (r:rest) + | p == r = maybePrefixMatch pat rest + | otherwise = Nothing toField :: String -> Maybe (InstalledPackageInfo -> String) -- backwards compatibility: @@ -563,52 +595,83 @@ toField s = showInstalledPackageInfoField s strList :: [String] -> String strList = show + -- ----------------------------------------------------------------------------- --- Manipulating package.conf files +-- 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 + -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 +-- ----------------------------------------------------------------------------- +-- Manipulating package.conf files writeNewConfig :: FilePath -> [InstalledPackageInfo] -> IO () writeNewConfig filename packages = do hPutStr stdout "Writing new package config file... " - h <- openFile filename WriteMode - hPutStrLn h (show packages) + 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 + let shown = concat $ intersperse ",\n " $ map show packages + fileContents = "[" ++ shown ++ "\n]" + hPutStrLn h fileContents 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 @@ -618,11 +681,11 @@ validatePackageConfig :: InstalledPackageInfo -> PackageDBStack -> Bool -- auto-ghc-libs -> Bool -- update - -> Bool -- force + -> Force -> IO () validatePackageConfig pkg db_stack auto_ghci_libs update force = do checkPackageId pkg - 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) @@ -670,9 +733,8 @@ resolveDeps db_stack p = updateDeps p [] -> dep_pkgid -- No installed package; use -- the version-less one -checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Bool - -> IO () -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 @@ -684,37 +746,40 @@ checkDuplicates db_stack pkg update force = do -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 @@ -867,7 +932,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 ] @@ -897,7 +962,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 @@ -914,7 +979,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 "") @@ -936,10 +1001,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 + +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)") + +dieForcible :: String -> IO () +dieForcible s = die (s ++ " (use --force to override)") ----------------------------------------- -- Cut and pasted from ghc/compiler/SysTools @@ -1012,6 +1087,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]