X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=9c6ba71485c21d36f720fdce9e725df3e005d74d;hb=c76c69c5b62f1ca4fa52d75b0dfbd37b7eddbb09;hp=3f8b0b366ba550e5dfa006a00381395ddd4b1820;hpb=b93ff3a3d656fb35a8ca8d15f1f24c4280b1adef;p=ghc-hetmet.git diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 3f8b0b3..9c6ba71 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -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) @@ -189,11 +194,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 ] -- @@ -375,7 +385,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 +393,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 +405,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 validatePackageConfig pkg db_stack auto_ghci_libs update force - let new_details = snd db_to_operate_on ++ [pkg] - savePackageConfig db_filename - maybeRestoreOldConfig db_filename $ + 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 +444,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 -- ----------------------------------------------------------------------------- @@ -565,49 +571,43 @@ strList = show -- ----------------------------------------------------------------------------- -- Manipulating package.conf files -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 - 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,11 +617,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) @@ -669,9 +669,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 @@ -683,37 +682,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 @@ -866,7 +868,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 ] @@ -896,7 +898,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 @@ -913,7 +915,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 "") @@ -935,10 +937,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 @@ -1011,6 +1023,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]