X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=697816eb099f86ab95549b5c03b5587da1ec0fa4;hp=2157d071a118ffae2ecbdde84e526db501cadf2e;hb=32b906efc4c6474d8af6fd7be2a3ddac2ae20a16;hpb=37557940c005d34fc755203139cfaa555fdb3cb8 diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 2157d07..697816e 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -40,17 +40,23 @@ import Text.PrettyPrint import qualified Control.Exception as Exception import Data.Maybe -import Data.Char ( isSpace ) -import Monad -import Directory -import System ( getArgs, getProgName, getEnv, exitWith, ExitCode(..) ) +import Data.Char ( isSpace, toLower ) +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 ) @@ -70,17 +76,7 @@ main = do bye ourCopyright (cli,nonopts,[]) -> runit cli nonopts - (_,_,errors) -> tryOldCmdLine errors args - --- If the new command-line syntax fails, then we try the old. If that --- fails too, then we output the original errors and the new syntax --- (so the old syntax is still available, but hidden). -tryOldCmdLine :: [String] -> [String] -> IO () -tryOldCmdLine errors args = do - case getOpt Permute oldFlags args of - (cli@(_:_),[],[]) -> - oldRunit cli - _failed -> do + (_,_,errors) -> do prog <- getProgramName die (concat errors ++ usageInfo (usageHeader prog) flags) @@ -97,7 +93,6 @@ data Flag | FlagForce | FlagForceFiles | FlagAutoGHCiLibs - | FlagDefinedName String String | FlagSimpleOutput | FlagNamesOnly deriving Eq @@ -107,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) @@ -130,17 +125,11 @@ flags = [ deprecFlags :: [OptDescr Flag] deprecFlags = [ - Option ['D'] ["define-name"] (ReqArg toDefined "NAME=VALUE") - "define NAME as VALUE" + -- put deprecated flags here ] - where - toDefined str = - case break (=='=') str of - (nm,[]) -> FlagDefinedName nm [] - (nm,_:val) -> FlagDefinedName nm val ourCopyright :: String -ourCopyright = "GHC package manager version " ++ version ++ "\n" +ourCopyright = "GHC package manager version " ++ Version.version ++ "\n" usageHeader :: String -> String usageHeader prog = substProg prog $ @@ -185,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 @@ -199,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 @@ -206,14 +208,13 @@ runit cli nonopts = do | FlagForceFiles `elem` cli = ForceFiles | otherwise = NoForce auto_ghci_libs = FlagAutoGHCiLibs `elem` cli - defines = [ (nm,val) | FlagDefinedName nm val <- cli ] -- -- first, parse the command case nonopts of ["register", filename] -> - registerPackage filename defines cli auto_ghci_libs False force + registerPackage filename cli auto_ghci_libs False force ["update", filename] -> - registerPackage filename defines cli auto_ghci_libs True force + registerPackage filename cli auto_ghci_libs True force ["unregister", pkgid_str] -> do pkgid <- readGlobPkgId pkgid_str unregisterPackage pkgid cli @@ -254,9 +255,6 @@ parseCheck parser str what = [x] -> return x _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what) -readPkgId :: String -> IO PackageIdentifier -readPkgId str = parseCheck parsePackageId str "package identifier" - readGlobPkgId :: String -> IO PackageIdentifier readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier" @@ -319,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 @@ -330,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 @@ -343,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 @@ -375,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 @@ -386,13 +395,12 @@ emptyPackageConfig = "[]" -- Registering registerPackage :: FilePath - -> [(String,String)] -- defines -> [Flag] -> Bool -- auto_ghci_libs -> Bool -- update -> Force -> IO () -registerPackage input defines flags auto_ghci_libs update force = do +registerPackage input flags auto_ghci_libs update force = do db_stack <- getPkgDatabases True flags let db_to_operate_on = my_head "db" db_stack @@ -408,9 +416,9 @@ registerPackage input defines flags auto_ghci_libs update force = do putStr ("Reading package info from " ++ show f ++ " ... ") readFile f - expanded <- expandEnvVars s defines force + expanded <- expandEnvVars s force - pkg <- parsePackageInfo expanded defines + pkg <- parsePackageInfo expanded putStrLn "done." validatePackageConfig pkg db_stack auto_ghci_libs update force @@ -421,9 +429,8 @@ registerPackage input defines flags auto_ghci_libs update force = do parsePackageInfo :: String - -> [(String,String)] -> IO InstalledPackageInfo -parsePackageInfo str defines = +parsePackageInfo str = case parseInstalledPackageInfo str of ParseOk _warns ok -> return ok ParseFailed err -> case locatedErrorMsg err of @@ -506,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 @@ -620,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 @@ -680,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 @@ -704,7 +717,7 @@ validatePackageConfig :: InstalledPackageInfo -> IO () validatePackageConfig pkg db_stack auto_ghci_libs update force = do checkPackageId pkg - checkDuplicates db_stack pkg update + checkDuplicates db_stack pkg update force mapM_ (checkDep db_stack force) (depends pkg) mapM_ (checkDir force) (importDirs pkg) mapM_ (checkDir force) (libraryDirs pkg) @@ -726,8 +739,8 @@ checkPackageId ipi = [] -> die ("invalid package identifier: " ++ str) _ -> die ("ambiguous package identifier: " ++ str) -checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> IO () -checkDuplicates db_stack pkg update = do +checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Force -> IO () +checkDuplicates db_stack pkg update force = do let pkgid = package pkg (_top_db_name, pkgs) : _ = db_stack @@ -737,6 +750,14 @@ checkDuplicates db_stack pkg update = do when (not update && (pkgid `elem` map package pkgs)) $ die ("package " ++ showPackageId pkgid ++ " is already installed") + let + uncasep = map toLower . showPackageId + dups = filter ((== uncasep pkgid) . uncasep) (map package pkgs) + + 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) checkDir :: Force -> String -> IO () @@ -851,114 +872,11 @@ okInModuleName c #endif --- ----------------------------------------------------------------------------- --- The old command-line syntax, supported for backwards compatibility - -data OldFlag - = OF_Config FilePath - | OF_Input FilePath - | OF_List - | OF_ListLocal - | OF_Add Bool {- True => replace existing info -} - | OF_Remove String | OF_Show String - | OF_Field String | OF_AutoGHCiLibs | OF_Force - | OF_DefinedName String String - | OF_GlobalConfig FilePath - deriving (Eq) - -isAction :: OldFlag -> Bool -isAction OF_Config{} = False -isAction OF_Field{} = False -isAction OF_Input{} = False -isAction OF_AutoGHCiLibs{} = False -isAction OF_Force{} = False -isAction OF_DefinedName{} = False -isAction OF_GlobalConfig{} = False -isAction _ = True - -oldFlags :: [OptDescr OldFlag] -oldFlags = [ - Option ['f'] ["config-file"] (ReqArg OF_Config "FILE") - "use the specified package config file", - Option ['l'] ["list-packages"] (NoArg OF_List) - "list packages in all config files", - Option ['L'] ["list-local-packages"] (NoArg OF_ListLocal) - "list packages in the specified config file", - Option ['a'] ["add-package"] (NoArg (OF_Add False)) - "add a new package", - Option ['u'] ["update-package"] (NoArg (OF_Add True)) - "update package with new configuration", - Option ['i'] ["input-file"] (ReqArg OF_Input "FILE") - "read new package info from specified file", - Option ['s'] ["show-package"] (ReqArg OF_Show "NAME") - "show the configuration for package NAME", - Option [] ["field"] (ReqArg OF_Field "FIELD") - "(with --show-package) Show field FIELD only", - Option [] ["force"] (NoArg OF_Force) - "ignore missing directories/libraries", - Option ['r'] ["remove-package"] (ReqArg OF_Remove "NAME") - "remove an installed package", - Option ['g'] ["auto-ghci-libs"] (NoArg OF_AutoGHCiLibs) - "automatically build libs for GHCi (with -a)", - Option ['D'] ["define-name"] (ReqArg toDefined "NAME=VALUE") - "define NAME as VALUE", - Option [] ["global-conf"] (ReqArg OF_GlobalConfig "FILE") - "location of the global package config" - ] - where - toDefined str = - case break (=='=') str of - (nm,[]) -> OF_DefinedName nm [] - (nm,_:val) -> OF_DefinedName nm val - -oldRunit :: [OldFlag] -> IO () -oldRunit clis = do - let new_flags = [ f | Just f <- map conv clis ] - - conv (OF_GlobalConfig f) = Just (FlagGlobalConfig f) - conv (OF_Config f) = Just (FlagConfig f) - conv _ = Nothing - - - - let fields = [ f | OF_Field f <- clis ] - - let auto_ghci_libs = any isAuto clis - where isAuto OF_AutoGHCiLibs = True; isAuto _ = False - input_file = my_head "inp" ([ f | (OF_Input f) <- clis] ++ ["-"]) - - force = if OF_Force `elem` clis then ForceAll else NoForce - - defines = [ (nm,val) | OF_DefinedName nm val <- clis ] - - case [ c | c <- clis, isAction c ] of - [ OF_List ] -> listPackages new_flags Nothing Nothing - [ OF_ListLocal ] -> listPackages new_flags Nothing Nothing - [ OF_Add upd ] -> - registerPackage input_file defines new_flags auto_ghci_libs upd force - [ OF_Remove pkgid_str ] -> do - pkgid <- readPkgId pkgid_str - unregisterPackage pkgid new_flags - [ OF_Show pkgid_str ] - | null fields -> do - pkgid <- readPkgId pkgid_str - describePackage new_flags pkgid - | otherwise -> do - pkgid <- readPkgId pkgid_str - mapM_ (describeField new_flags pkgid) fields - _ -> do - prog <- getProgramName - die (usageInfo (usageHeader prog) flags) - -my_head :: String -> [a] -> a -my_head s [] = error s -my_head s (x:xs) = x - -- --------------------------------------------------------------------------- -- expanding environment variables in the package configuration -expandEnvVars :: String -> [(String, String)] -> Force -> IO String -expandEnvVars str defines force = go str "" +expandEnvVars :: String -> Force -> IO String +expandEnvVars str force = go str "" where go "" acc = return $! reverse acc go ('$':'{':str) acc | (var, '}':rest) <- break close str @@ -970,10 +888,7 @@ expandEnvVars str defines force = go str "" lookupEnvVar :: String -> IO String lookupEnvVar nm = - case lookup nm defines of - Just x | not (null x) -> return x - _ -> - catch (System.getEnv nm) + catch (System.Environment.getEnv nm) (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++ show nm) return "") @@ -1011,8 +926,12 @@ ignoreError s = do hFlush stdout; hPutStrLn stderr (s ++ " (ignoring)") 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 + ----------------------------------------- --- 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 @@ -1042,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