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 )
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)
]
ourCopyright :: String
-ourCopyright = "GHC package manager version " ++ version ++ "\n"
+ourCopyright = "GHC package manager version " ++ Version.version ++ "\n"
usageHeader :: String -> String
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
runit :: [Flag] -> [String] -> IO ()
runit cli nonopts = do
+ installSignalHandlers -- catch ^C and clean up
prog <- getProgramName
let
force
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
| 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
-- 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
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
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
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
"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
-> 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)
[] -> 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
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 ()
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 "")
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
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
projects / ghc-hetmet.git / blobdiff