X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=f310cc6e4763c697b0144cfbfcb05a1caa03b498;hb=0c04c63de98877842dddfb5b437983dd9bdad788;hp=f2087b979b01b2c8bdcb49ac009dc4a679bacdb2;hpb=58c73734b4397ac4ee635895b0a67a36514ef383;p=ghc-hetmet.git diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index f2087b9..f310cc6 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -364,18 +364,27 @@ allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo] allPackagesInStack = concatMap snd getPkgDatabases :: Bool -> [Flag] -> IO PackageDBStack -getPkgDatabases modify flags = do +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 -- location is passed to the binary using the --global-config flag by the -- wrapper script. let err_msg = "missing --global-conf option, location of global package.conf unknown\n" global_conf <- - case [ f | FlagGlobalConfig f <- flags ] of + case [ f | FlagGlobalConfig f <- my_flags ] of [] -> 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" @@ -416,7 +425,7 @@ getPkgDatabases modify flags = do -- This is the database we modify by default. virt_global_conf = last env_stack - let db_flags = [ f | Just f <- map is_db_flag flags ] + let db_flags = [ f | Just f <- map is_db_flag my_flags ] where is_db_flag FlagUser = Just user_conf is_db_flag FlagGlobal = Just virt_global_conf is_db_flag (FlagConfig f) = Just f @@ -440,7 +449,7 @@ getPkgDatabases modify flags = do -- stack, unless any of them are present in the stack -- already. flag_stack = filter (`notElem` env_stack) - [ f | FlagConfig f <- reverse flags ] + [ f | FlagConfig f <- reverse my_flags ] ++ env_stack modifying f @@ -456,10 +465,10 @@ getPkgDatabases modify flags = do 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) @@ -475,8 +484,8 @@ registerPackage :: FilePath -> Bool -- update -> Force -> IO () -registerPackage input flags auto_ghci_libs update force = do - db_stack <- getPkgDatabases True flags +registerPackage input my_flags auto_ghci_libs update force = do + db_stack <- getPkgDatabases True my_flags let db_to_operate_on = my_head "db" db_stack db_filename = fst db_to_operate_on @@ -522,15 +531,15 @@ hidePackage :: PackageIdentifier -> [Flag] -> IO () hidePackage = modifyPackage (\p -> [p{exposed=False}]) unregisterPackage :: PackageIdentifier -> [Flag] -> IO () -unregisterPackage = modifyPackage (\p -> []) +unregisterPackage = modifyPackage (\_ -> []) modifyPackage :: (InstalledPackageInfo -> [InstalledPackageInfo]) -> PackageIdentifier -> [Flag] -> IO () -modifyPackage fn pkgid flags = do - db_stack <- getPkgDatabases True{-modify-} flags +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 @@ -545,9 +554,9 @@ modifyPackage fn pkgid flags = do -- Listing packages listPackages :: [Flag] -> Maybe PackageArg -> Maybe (String->Bool) -> IO () -listPackages flags mPackageName mModuleName = do - let simple_output = FlagSimpleOutput `elem` flags - db_stack <- getPkgDatabases False flags +listPackages my_flags mPackageName mModuleName = do + let simple_output = FlagSimpleOutput `elem` 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)) @@ -586,8 +595,8 @@ listPackages flags mPackageName mModuleName = do where doc = text (display (package p)) show_simple db_stack = do - let showPkg = if FlagNamesOnly `elem` flags then display . pkgName - else display + let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName + else display pkgs = map showPkg $ sortBy compPkgIdVer $ map package (allPackagesInStack db_stack) when (not (null pkgs)) $ @@ -597,8 +606,8 @@ listPackages flags mPackageName mModuleName = do -- Prints the highest (hidden or exposed) version of a package latestPackage :: [Flag] -> PackageIdentifier -> IO () -latestPackage flags pkgid = do - db_stack <- getPkgDatabases False flags +latestPackage my_flags pkgid = do + db_stack <- getPkgDatabases False my_flags ps <- findPackages db_stack (Id pkgid) show_pkg (sortBy compPkgIdVer (map package ps)) where @@ -609,14 +618,14 @@ latestPackage flags pkgid = do -- Describe describePackage :: [Flag] -> PackageArg -> IO () -describePackage flags pkgarg = do - db_stack <- getPkgDatabases False flags +describePackage my_flags pkgarg = do + db_stack <- getPkgDatabases False my_flags ps <- findPackages db_stack pkgarg doDump ps dumpPackages :: [Flag] -> IO () -dumpPackages flags = do - db_stack <- getPkgDatabases False flags +dumpPackages my_flags = do + db_stack <- getPkgDatabases False my_flags doDump (allPackagesInStack db_stack) doDump :: [InstalledPackageInfo] -> IO () @@ -626,7 +635,7 @@ doDump = mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo 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) + [] -> dieWith 2 ("cannot find package " ++ pkg_msg pkgarg) ps -> return ps where all_pkgs = allPackagesInStack db_stack @@ -649,8 +658,8 @@ compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2 -- Field describeField :: [Flag] -> PackageArg -> [String] -> IO () -describeField flags pkgarg fields = do - db_stack <- getPkgDatabases False flags +describeField my_flags pkgarg fields = do + db_stack <- getPkgDatabases False my_flags fns <- toFields fields ps <- findPackages db_stack pkgarg let top_dir = takeDirectory (fst (last db_stack)) @@ -715,8 +724,8 @@ strList = show -- Check: Check consistency of installed packages checkConsistency :: [Flag] -> IO () -checkConsistency flags = do - db_stack <- getPkgDatabases True flags +checkConsistency my_flags = do + 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 @@ -727,7 +736,7 @@ checkConsistency flags = do return (pid, broken_deps) mapM_ (putStrLn . render . show_func) broken_pkgs where - show_func | FlagSimpleOutput `elem` flags = show_simple + show_func | FlagSimpleOutput `elem` my_flags = show_simple | otherwise = show_normal show_simple (pid,deps) = text (display pid) <> colon @@ -747,7 +756,7 @@ missingPackageDeps pkg 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 + 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 -- as broken. (#1750) @@ -802,20 +811,19 @@ savingOldConfig filename io = Exception.block $ do ioError err return False (do hPutStrLn stdout "done."; io) - `Exception.catch` \e -> do + `onException` do hPutStr stdout ("WARNING: an error was encountered while writing " ++ "the new configuration.\n") -- remove any partially complete new version: - try (removeFile filename) + removeFile filename `catchIO` \_ -> return () -- 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) + `catchIO` \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 @@ -988,7 +996,7 @@ okInModuleName c -- expanding environment variables in the package configuration expandEnvVars :: String -> Force -> IO String -expandEnvVars str force = go str "" +expandEnvVars str0 force = go str0 "" where go "" acc = return $! reverse acc go ('$':'{':str) acc | (var, '}':rest) <- break close str @@ -1017,11 +1025,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 @@ -1039,8 +1050,8 @@ dieForcible :: String -> IO () dieForcible s = die (s ++ " (use --force to override)") my_head :: String -> [a] -> a -my_head s [] = error s -my_head s (x:xs) = x +my_head s [] = error s +my_head _ (x : _) = x ----------------------------------------- -- Cut and pasted from ghc/compiler/main/SysTools @@ -1107,3 +1118,31 @@ 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 + +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 +