X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=cc634ea358ad588990c788f554b8d14a37bca557;hb=34b0bd51383120fe9a2da21d5c0af3c9a662e598;hp=3b0b4385df83ccc7df329a45539aaa9b62b76eb3;hpb=cf81f273637efb4e2199493814ca57d9d447f839;p=ghc-hetmet.git diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 3b0b438..cc634ea 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 @@ -383,7 +385,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 @@ -400,10 +401,10 @@ registerPackage input defines flags auto_ghci_libs update force = do 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 @@ -436,15 +437,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 +564,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 = 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,16 +611,15 @@ validatePackageConfig :: InstalledPackageInfo -> Bool -- auto-ghc-libs -> Bool -- update -> Bool -- force - -> IO [PackageIdentifier] + -> 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 force 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], @@ -671,7 +663,7 @@ resolveDeps db_stack p = updateDeps p -- the version-less one checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Bool - -> IO [PackageIdentifier] + -> IO () checkDuplicates db_stack pkg update force = do let pkgid = package pkg @@ -682,103 +674,6 @@ 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 () @@ -851,30 +746,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 @@ -1062,18 +933,6 @@ dieOrForce force s | force = do hFlush stdout; hPutStrLn stderr (s ++ " (ignoring)") | otherwise = die (s ++ " (use --force to override)") -diePretty :: Doc -> IO () -diePretty doc = do - hFlush stdout - prog <- getProgramName - hPutStrLn stderr $ render $ (text prog <> colon $$ nest 2 doc) - exitWith (ExitFailure 1) - -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)") - ----------------------------------------- -- Cut and pasted from ghc/compiler/SysTools @@ -1145,6 +1004,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]