X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=utils%2Fghc-pkg%2FMain.hs;h=697816eb099f86ab95549b5c03b5587da1ec0fa4;hb=32b906efc4c6474d8af6fd7be2a3ddac2ae20a16;hp=a89be047a2ad9c00f106f6490f5c831d267a1935;hpb=8789db32595b2f9de24fc6a51dd9c35ea197a7d5;p=ghc-hetmet.git diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index a89be04..697816e 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -41,16 +41,22 @@ import qualified Control.Exception as Exception import Data.Maybe import Data.Char ( isSpace, toLower ) -import Monad -import Directory -import System ( getArgs, getProgName, getEnv, exitWith, ExitCode(..) ) +import Control.Monad +import System.Directory ( doesDirectoryExist, getDirectoryContents, + doesFileExist, renameFile, removeFile ) +import System.Exit ( exitWith, ExitCode(..) ) +import System.Environment ( getArgs, getProgName, getEnv ) import System.IO import System.IO.Error (try) -import Data.List ( isPrefixOf, isSuffixOf, intersperse, sortBy ) +import Data.List ( isPrefixOf, isSuffixOf, intersperse, sortBy, nub ) +import Control.Concurrent #ifdef mingw32_HOST_OS import Foreign import Foreign.C.String +import GHC.ConsoleHandler +#else +import System.Posix #endif import IO ( isPermissionError, isDoesNotExistError ) @@ -96,9 +102,9 @@ flags = [ Option [] ["user"] (NoArg FlagUser) "use the current user's package database", Option [] ["global"] (NoArg FlagGlobal) - "(default) use the global package database", + "use the global package database", Option ['f'] ["package-conf"] (ReqArg FlagConfig "FILE") - "act upon specified package config file (only)", + "use the specified package config file", Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE") "location of the global package config", Option [] ["force"] (NoArg FlagForce) @@ -123,7 +129,7 @@ deprecFlags = [ ] ourCopyright :: String -ourCopyright = "GHC package manager version " ++ version ++ "\n" +ourCopyright = "GHC package manager version " ++ Version.version ++ "\n" usageHeader :: String -> String usageHeader prog = substProg prog $ @@ -168,6 +174,18 @@ usageHeader prog = substProg prog $ " Extract the specified field of the package description for the\n" ++ " specified package.\n" ++ "\n" ++ + " When asked to modify a database (register, unregister, update,\n"++ + " hide, expose, and also check), ghc-pkg modifies the global database by\n"++ + " default. Specifying --user causes it to act on the user database,\n"++ + " or --package-conf can be used to act on another database\n"++ + " entirely. When multiple of these options are given, the rightmost\n"++ + " one is used as the database to act upon.\n"++ + "\n"++ + " Commands that query the package database (list, latest, describe,\n"++ + " field) operate on the list of databases specified by the flags\n"++ + " --user, --global, and --package-conf. If none of these flags are\n"++ + " given, the default is --global --user.\n"++ + "\n" ++ " The following optional flags are also accepted:\n" substProg :: String -> String -> String @@ -182,6 +200,7 @@ data Force = ForceAll | ForceFiles | NoForce runit :: [Flag] -> [String] -> IO () runit cli nonopts = do + installSignalHandlers -- catch ^C and clean up prog <- getProgramName let force @@ -298,7 +317,7 @@ getPkgDatabases modify flags = do appdir <- getAppUserDataDirectory "ghc" let - subdir = targetARCH ++ '-':targetOS ++ '-':version + subdir = targetARCH ++ '-':targetOS ++ '-':Version.version archdir = appdir subdir user_conf = archdir "package.conf" user_exists <- doesFileExist user_conf @@ -309,7 +328,7 @@ getPkgDatabases modify flags = do | modify || user_exists = user_conf : global_confs ++ [global_conf] | otherwise = global_confs ++ [global_conf] - e_pkg_path <- try (getEnv "GHC_PACKAGE_PATH") + e_pkg_path <- try (System.Environment.getEnv "GHC_PACKAGE_PATH") let env_stack = case e_pkg_path of Left _ -> sys_databases @@ -322,29 +341,40 @@ getPkgDatabases modify flags = do -- This is the database we modify by default. virt_global_conf = last env_stack - -- -f flags on the command line add to the database stack, unless any - -- of them are present in the stack already. - let flag_stack = filter (`notElem` env_stack) - [ f | FlagConfig f <- reverse flags ] ++ env_stack + let db_flags = [ f | Just f <- map is_db_flag flags ] + where is_db_flag FlagUser = Just user_conf + is_db_flag FlagGlobal = Just virt_global_conf + is_db_flag (FlagConfig f) = Just f + is_db_flag _ = Nothing - -- Now we have the full stack of databases. Next, if the current - -- command is a "modify" type command, then we truncate the stack - -- so that the topmost element is the database being modified. final_stack <- if not modify - then return flag_stack + then -- For a "read" command, we use all the databases + -- specified on the command line. If there are no + -- command-line flags specifying databases, the default + -- is to use all the ones we know about. + if null db_flags then return env_stack + else return (reverse (nub db_flags)) else let - go (FlagUser : fs) = modifying user_conf - go (FlagGlobal : fs) = modifying virt_global_conf - go (FlagConfig f : fs) = modifying f - go (_ : fs) = go fs - go [] = modifying virt_global_conf + -- For a "modify" command, treat all the databases as + -- a stack, where we are modifying the top one, but it + -- can refer to packages in databases further down the + -- stack. + + -- -f flags on the command line add to the database + -- stack, unless any of them are present in the stack + -- already. + flag_stack = filter (`notElem` env_stack) + [ f | FlagConfig f <- reverse flags ] + ++ env_stack modifying f | f `elem` flag_stack = return (dropWhile (/= f) flag_stack) | otherwise = die ("requesting modification of database:\n\t" ++ f ++ "\n\twhich is not in the database stack.") in - go flags + if null db_flags + then modifying virt_global_conf + else modifying (head db_flags) db_stack <- mapM readParseDatabase final_stack return db_stack @@ -354,8 +384,8 @@ readParseDatabase filename = do str <- readFile filename `Exception.catch` \_ -> return emptyPackageConfig let packages = read str Exception.evaluate packages - `Exception.catch` \_ -> - die (filename ++ ": parse error in package config file") + `Exception.catch` \e-> + die ("error while parsing " ++ filename ++ ": " ++ show e) return (filename,packages) emptyPackageConfig :: String @@ -483,8 +513,8 @@ listPackages flags mPackageName mModuleName = do else showPackageId pkgs = map showPkg $ sortBy compPkgIdVer $ map package (concatMap snd db_stack) - when (null pkgs) $ die "no matches" - hPutStrLn stdout $ concat $ intersperse " " pkgs + when (not (null pkgs)) $ + hPutStrLn stdout $ concat $ intersperse " " pkgs -- ----------------------------------------------------------------------------- -- Prints the highest (hidden or exposed) version of a package @@ -597,7 +627,9 @@ strList = show checkConsistency :: [Flag] -> IO () checkConsistency flags = do - db_stack <- getPkgDatabases False flags + db_stack <- getPkgDatabases True 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)) $ concatMap snd db_stack broken_pkgs = do (pid, p) <- pkgs @@ -657,17 +689,21 @@ savingOldConfig filename io = Exception.block $ do "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" + (do hPutStrLn stdout "done."; io) + `Exception.catch` \e -> do + hPutStr stdout ("WARNING: an error was encountered while writing " ++ "the new configuration.\n") + -- remove any partially complete new version: + try (removeFile filename) + -- 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) - ioError e + hPutStr stdout "Attempting to restore the old configuration... " + do renameFile oldFile filename + hPutStrLn stdout "done." + `catch` \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 @@ -718,7 +754,7 @@ checkDuplicates db_stack pkg update force = do uncasep = map toLower . showPackageId dups = filter ((== uncasep pkgid) . uncasep) (map package pkgs) - when (not (null dups)) $ dieOrForceAll force $ + when (not update && not (null dups)) $ dieOrForceAll force $ "Package names may be treated case-insensitively in the future.\n"++ "Package " ++ showPackageId pkgid ++ " overlaps with: " ++ unwords (map showPackageId dups) @@ -852,7 +888,7 @@ expandEnvVars str force = go str "" lookupEnvVar :: String -> IO String lookupEnvVar nm = - catch (System.getEnv nm) + catch (System.Environment.getEnv nm) (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++ show nm) return "") @@ -895,7 +931,7 @@ my_head s [] = error s my_head s (x:xs) = x ----------------------------------------- --- Cut and pasted from ghc/compiler/SysTools +-- Cut and pasted from ghc/compiler/main/SysTools #if defined(mingw32_HOST_OS) subst :: Char -> Char -> String -> String @@ -925,3 +961,32 @@ foreign import stdcall unsafe "GetModuleFileNameA" getExecDir :: String -> IO (Maybe String) getExecDir _ = return Nothing #endif + +----------------------------------------- +-- Adapted from ghc/compiler/utils/Panic + +installSignalHandlers :: IO () +installSignalHandlers = do + threadid <- myThreadId + let + interrupt = throwTo threadid (Exception.ErrorCall "interrupted") + -- +#if !defined(mingw32_HOST_OS) + installHandler sigQUIT (Catch interrupt) Nothing + installHandler sigINT (Catch interrupt) Nothing + return () +#elif __GLASGOW_HASKELL__ >= 603 + -- GHC 6.3+ has support for console events on Windows + -- NOTE: running GHCi under a bash shell for some reason requires + -- you to press Ctrl-Break rather than Ctrl-C to provoke + -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know + -- why --SDM 17/12/2004 + let sig_handler ControlC = interrupt + sig_handler Break = interrupt + sig_handler _ = return () + + installHandler (Catch sig_handler) + return () +#else + return () -- nothing +#endif