-{-# OPTIONS -fglasgow-exts #-}
+{-# OPTIONS -fglasgow-exts -cpp #-}
-----------------------------------------------------------------------------
--
-- (c) The University of Glasgow 2004.
module Main (main) where
import Version ( version, targetOS, targetARCH )
-import Distribution.InstalledPackageInfo
+import Distribution.InstalledPackageInfo hiding (depends)
import Distribution.Compat.ReadP
import Distribution.ParseUtils
import Distribution.Package
+import Distribution.Text
import Distribution.Version
import System.FilePath
-
-#ifdef USING_COMPAT
-import Compat.Directory ( getAppUserDataDirectory, createDirectoryIfMissing )
-import Compat.RawSystem ( rawSystem )
-#else
-import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing )
import System.Cmd ( rawSystem )
-#endif
+import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing )
import Prelude
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,
+ unfoldr, break )
+#if __GLASGOW_HASKELL__ > 604
+import Data.List ( isInfixOf )
+#else
+import Data.List ( tails )
+#endif
+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 )
+#if defined(GLOB)
+import System.Process(runInteractiveCommand)
+import qualified System.Info(os)
+#endif
+
-- -----------------------------------------------------------------------------
-- Entry point
main = do
args <- getArgs
- case getOpt Permute flags args of
+ case getOpt Permute (flags ++ deprecFlags) args of
(cli,_,[]) | FlagHelp `elem` cli -> do
prog <- getProgramName
bye (usageInfo (usageHeader prog) flags)
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)
| FlagForce
| FlagForceFiles
| FlagAutoGHCiLibs
- | FlagDefinedName String String
| FlagSimpleOutput
| FlagNamesOnly
+ | FlagIgnoreCase
deriving Eq
flags :: [OptDescr Flag]
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)
"automatically build libs for GHCi (with register)",
Option ['?'] ["help"] (NoArg FlagHelp)
"display this help and exit",
- Option ['D'] ["define-name"] (ReqArg toDefined "NAME=VALUE")
- "define NAME as VALUE",
Option ['V'] ["version"] (NoArg FlagVersion)
"output version information and exit",
Option [] ["simple-output"] (NoArg FlagSimpleOutput)
"print output in easy-to-parse format for some commands",
Option [] ["names-only"] (NoArg FlagNamesOnly)
- "only print package names, not versions; can only be used with list --simple-output"
+ "only print package names, not versions; can only be used with list --simple-output",
+ Option [] ["ignore-case"] (NoArg FlagIgnoreCase)
+ "ignore case for substring matching"
+ ]
+
+deprecFlags :: [OptDescr Flag]
+deprecFlags = [
+ -- 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 $
" all the registered versions will be listed in ascending order.\n" ++
" Accepts the --simple-output flag.\n" ++
"\n" ++
- " $p latest pkg\n" ++
+ " $p find-module {module}\n" ++
+ " List registered packages exposing module {module} in the global\n" ++
+ " database, and also the user database if --user is given.\n" ++
+ " All the registered versions will be listed in ascending order.\n" ++
+ " Accepts the --simple-output flag.\n" ++
+ "\n" ++
+ " $p latest {pkg-id}\n" ++
" Prints the highest registered version of a package.\n" ++
"\n" ++
" $p check\n" ++
" Check the consistency of package depenencies and list broken packages.\n" ++
" Accepts the --simple-output flag.\n" ++
"\n" ++
- " $p describe {pkg-id}\n" ++
+ " $p describe {pkg}\n" ++
" Give the registered description for the specified package. The\n" ++
" description is returned in precisely the syntax required by $p\n" ++
" register.\n" ++
"\n" ++
- " $p field {pkg-id} {field}\n" ++
+ " $p field {pkg} {field}\n" ++
" Extract the specified field of the package description for the\n" ++
- " specified package.\n" ++
+ " specified package. Accepts comma-separated multiple fields.\n" ++
+ "\n" ++
+ " Substring matching is supported for {module} in find-module and\n" ++
+ " for {pkg} in list, describe, and field, where a '*' indicates\n" ++
+ " open substring ends (prefix*, *suffix, *infix*).\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"
data Force = ForceAll | ForceFiles | NoForce
+data PackageArg = Id PackageIdentifier | Substring String (String->Bool)
+
runit :: [Flag] -> [String] -> IO ()
runit cli nonopts = do
+ installSignalHandlers -- catch ^C and clean up
prog <- getProgramName
let
force
| FlagForceFiles `elem` cli = ForceFiles
| otherwise = NoForce
auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
- defines = [ (nm,val) | FlagDefinedName nm val <- cli ]
+ splitFields fields = unfoldr splitComma (',':fields)
+ where splitComma "" = Nothing
+ splitComma fs = Just $ break (==',') (tail fs)
+
+ substringCheck :: String -> Maybe (String -> Bool)
+ substringCheck "" = Nothing
+ substringCheck "*" = Just (const True)
+ substringCheck [_] = Nothing
+ substringCheck (h:t) =
+ case (h, init t, last t) of
+ ('*',s,'*') -> Just (isInfixOf (f s) . f)
+ ('*',_, _ ) -> Just (isSuffixOf (f t) . f)
+ ( _ ,s,'*') -> Just (isPrefixOf (f (h:s)) . f)
+ _ -> Nothing
+ where f | FlagIgnoreCase `elem` cli = map toLower
+ | otherwise = id
+#if defined(GLOB)
+ glob x | System.Info.os=="mingw32" = do
+ -- glob echoes its argument, after win32 filename globbing
+ (_,o,_,_) <- runInteractiveCommand ("glob "++x)
+ txt <- hGetContents o
+ return (read txt)
+ glob x | otherwise = return [x]
+#endif
--
-- first, parse the command
case nonopts of
+#if defined(GLOB)
+ -- dummy command to demonstrate usage and permit testing
+ -- without messing things up; use glob to selectively enable
+ -- windows filename globbing for file parameters
+ -- register, update, FlagGlobalConfig, FlagConfig; others?
+ ["glob", filename] -> do
+ print filename
+ glob filename >>= print
+#endif
["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
pkgid <- readGlobPkgId pkgid_str
hidePackage pkgid cli
["list"] -> do
- listPackages cli Nothing
- ["list", pkgid_str] -> do
- pkgid <- readGlobPkgId pkgid_str
- listPackages cli (Just pkgid)
+ listPackages cli Nothing Nothing
+ ["list", pkgid_str] ->
+ case substringCheck pkgid_str of
+ Nothing -> do pkgid <- readGlobPkgId pkgid_str
+ listPackages cli (Just (Id pkgid)) Nothing
+ Just m -> listPackages cli (Just (Substring pkgid_str m)) Nothing
+ ["find-module", moduleName] -> do
+ let match = maybe (==moduleName) id (substringCheck moduleName)
+ listPackages cli Nothing (Just match)
["latest", pkgid_str] -> do
pkgid <- readGlobPkgId pkgid_str
latestPackage cli pkgid
- ["describe", pkgid_str] -> do
- pkgid <- readGlobPkgId pkgid_str
- describePackage cli pkgid
- ["field", pkgid_str, field] -> do
- pkgid <- readGlobPkgId pkgid_str
- describeField cli pkgid field
+ ["describe", pkgid_str] ->
+ case substringCheck pkgid_str of
+ Nothing -> do pkgid <- readGlobPkgId pkgid_str
+ describePackage cli (Id pkgid)
+ Just m -> describePackage cli (Substring pkgid_str m)
+ ["field", pkgid_str, fields] ->
+ case substringCheck pkgid_str of
+ Nothing -> do pkgid <- readGlobPkgId pkgid_str
+ describeField cli (Id pkgid) (splitFields fields)
+ Just m -> describeField cli (Substring pkgid_str m)
+ (splitFields fields)
["check"] -> do
checkConsistency cli
[] -> do
[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"
parseGlobPackageId :: ReadP r PackageIdentifier
parseGlobPackageId =
- parsePackageId
+ parse
+++
(do n <- parsePackageName; string "-*"
return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
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
-- 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
putStr ("Reading package info from " ++ show f ++ " ... ")
readFile f
- expanded <- expandEnvVars s defines force
+ expanded <- expandEnvVars s force
- pkg0 <- parsePackageInfo expanded defines
+ pkg <- parsePackageInfo expanded
putStrLn "done."
- let pkg = resolveDeps db_stack pkg0
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
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
modifyPackage fn pkgid flags = do
db_stack <- getPkgDatabases True{-modify-} flags
let ((db_name, pkgs) : _) = db_stack
- ps <- findPackages [(db_name,pkgs)] pkgid
+ ps <- findPackages [(db_name,pkgs)] (Id pkgid)
let pids = map package ps
let new_config = concat (map modify pkgs)
modify pkg
-- -----------------------------------------------------------------------------
-- Listing packages
-listPackages :: [Flag] -> Maybe PackageIdentifier -> IO ()
-listPackages flags mPackageName = do
+listPackages :: [Flag] -> Maybe PackageArg -> Maybe (String->Bool) -> IO ()
+listPackages flags mPackageName mModuleName = do
let simple_output = FlagSimpleOutput `elem` flags
db_stack <- getPkgDatabases False 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))
db_stack
+ | Just match <- mModuleName = -- packages which expose mModuleName
+ map (\(conf,pkgs) -> (conf, filter (match `exposedInPkg`) pkgs))
+ db_stack
| otherwise = db_stack
db_stack_sorted
EQ -> pkgVersion p1 `compare` pkgVersion p2
where (p1,p2) = (package pkg1, package pkg2)
+ match `exposedInPkg` pkg = any match (exposedModules pkg)
+
pkg_map = map (\p -> (package p, p)) $ concatMap snd db_stack
show_func = if simple_output then show_simple else mapM_ (show_normal pkg_map)
| isBrokenPackage p pkg_map = braces doc
| exposed p = doc
| otherwise = parens doc
- where doc = text (showPackageId (package p))
+ where doc = text (display (package p))
show_simple db_stack = do
let showPkg = if FlagNamesOnly `elem` flags then pkgName
- else showPackageId
+ else display
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
latestPackage :: [Flag] -> PackageIdentifier -> IO ()
latestPackage flags pkgid = do
db_stack <- getPkgDatabases False flags
- ps <- findPackages db_stack pkgid
+ ps <- findPackages db_stack (Id pkgid)
show_pkg (sortBy compPkgIdVer (map package ps))
where
show_pkg [] = die "no matches"
- show_pkg pids = hPutStrLn stdout (showPackageId (last pids))
+ show_pkg pids = hPutStrLn stdout (display (last pids))
-- -----------------------------------------------------------------------------
-- Describe
-describePackage :: [Flag] -> PackageIdentifier -> IO ()
-describePackage flags pkgid = do
+describePackage :: [Flag] -> PackageArg -> IO ()
+describePackage flags pkgarg = do
db_stack <- getPkgDatabases False flags
- ps <- findPackages db_stack pkgid
+ ps <- findPackages db_stack pkgarg
mapM_ (putStrLn . showInstalledPackageInfo) ps
-- PackageId is can have globVersion for the version
-findPackages :: PackageDBStack -> PackageIdentifier -> IO [InstalledPackageInfo]
-findPackages db_stack pkgid
- = case [ p | p <- all_pkgs, pkgid `matchesPkg` p ] of
- [] -> die ("cannot find package " ++ showPackageId pkgid)
+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)
ps -> return ps
where
all_pkgs = concat (map snd db_stack)
+ pkg_msg (Id pkgid) = display pkgid
+ pkg_msg (Substring pkgpat _) = "matching "++pkgpat
matches :: PackageIdentifier -> PackageIdentifier -> Bool
pid `matches` pid'
= (pkgName pid == pkgName pid')
&& (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
-matchesPkg :: PackageIdentifier -> InstalledPackageInfo -> Bool
-pid `matchesPkg` pkg = pid `matches` package pkg
+matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
+(Id pid) `matchesPkg` pkg = pid `matches` package pkg
+(Substring _ m) `matchesPkg` pkg = m (display (package pkg))
compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering
compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
-- -----------------------------------------------------------------------------
-- Field
-describeField :: [Flag] -> PackageIdentifier -> String -> IO ()
-describeField flags pkgid field = do
+describeField :: [Flag] -> PackageArg -> [String] -> IO ()
+describeField flags pkgarg fields = do
db_stack <- getPkgDatabases False flags
- case toField field of
- Nothing -> die ("unknown field: " ++ field)
- Just fn -> do
- ps <- findPackages db_stack pkgid
- let top_dir = takeDirectory (fst (last db_stack))
- mapM_ (putStrLn . fn) (mungePackagePaths top_dir ps)
+ fns <- toFields fields
+ ps <- findPackages db_stack pkgarg
+ let top_dir = takeDirectory (fst (last db_stack))
+ mapM_ (selectFields fns) (mungePackagePaths top_dir ps)
+ where toFields [] = return []
+ toFields (f:fs) = case toField f of
+ Nothing -> die ("unknown field: " ++ f)
+ Just fn -> do fns <- toFields fs
+ return (fn:fns)
+ selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns
mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]
--- Replace the string "$topdir" at the beginning of a path
+-- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path
-- with the current topdir (obtained from the -B option).
mungePackagePaths top_dir ps = map munge_pkg ps
where
munge_paths = map munge_path
munge_path p
- | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p'
- | otherwise = p
+ | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p'
+ | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p'
+ | otherwise = p
+
+ toHttpPath p = "file:///" ++ p
maybePrefixMatch :: String -> String -> Maybe String
maybePrefixMatch [] rest = Just rest
toField "extra_libraries" = Just $ strList . extraLibraries
toField "include_dirs" = Just $ strList . includeDirs
toField "c_includes" = Just $ strList . includes
-toField "package_deps" = Just $ strList . map showPackageId. depends
+toField "package_deps" = Just $ strList . map display. depends
toField "extra_cc_opts" = Just $ strList . ccOptions
toField "extra_ld_opts" = Just $ strList . ldOptions
toField "framework_dirs" = Just $ strList . frameworkDirs
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
show_func | FlagSimpleOutput `elem` flags = show_simple
| otherwise = show_normal
show_simple (pid,deps) =
- text (showPackageId pid) <> colon
- <+> fsep (punctuate comma (map (text . showPackageId) deps))
+ text (display pid) <> colon
+ <+> fsep (punctuate comma (map (text . display) deps))
show_normal (pid,deps) =
- text "package" <+> text (showPackageId pid) <+> text "has missing dependencies:"
- $$ nest 4 (fsep (punctuate comma (map (text . showPackageId) deps)))
+ text "package" <+> text (display pid) <+> text "has missing dependencies:"
+ $$ nest 4 (fsep (punctuate comma (map (text . display) deps)))
missingPackageDeps :: InstalledPackageInfo
-> [(PackageIdentifier, InstalledPackageInfo)]
-> [PackageIdentifier]
missingPackageDeps pkg pkg_map =
[ d | d <- depends pkg, isNothing (lookup d pkg_map)] ++
- [ d | d <- depends pkg, Just p <- return (lookup d pkg_map), isBrokenPackage p pkg_map]
+ [ d | d <- depends pkg, Just p <- return (lookup d pkg_map),
+ isBrokenPackage p pkg_map]
isBrokenPackage :: InstalledPackageInfo -> [(PackageIdentifier, InstalledPackageInfo)] -> Bool
-isBrokenPackage pkg pkg_map = not . null $ missingPackageDeps pkg pkg_map
-
+isBrokenPackage pkg pkg_map
+ = not . null $ missingPackageDeps pkg (filter notme pkg_map)
+ 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)
-- -----------------------------------------------------------------------------
-- Manipulating package.conf files
"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)
-- we check that the package id can be parsed properly here.
checkPackageId :: InstalledPackageInfo -> IO ()
checkPackageId ipi =
- let str = showPackageId (package ipi) in
- case [ x | (x,ys) <- readP_to_S parsePackageId str, all isSpace ys ] of
+ let str = display (package ipi) in
+ case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
[_] -> return ()
[] -> die ("invalid package identifier: " ++ str)
_ -> die ("ambiguous package identifier: " ++ str)
-resolveDeps :: PackageDBStack -> InstalledPackageInfo -> InstalledPackageInfo
-resolveDeps db_stack p = updateDeps p
- where
- -- The input package spec is allowed to give a package dependency
- -- without a version number; e.g.
- -- depends: base
- -- Here, we update these dependencies without version numbers to
- -- match the actual versions of the relevant packages installed.
- updateDeps p = p{depends = map resolveDep (depends p)}
-
- resolveDep dep_pkgid
- | realVersion dep_pkgid = dep_pkgid
- | otherwise = lookupDep dep_pkgid
-
- lookupDep dep_pkgid
- = let
- name = pkgName dep_pkgid
- in
- case [ pid | p <- concat (map snd db_stack),
- let pid = package p,
- pkgName pid == name ] of
- (pid:_) -> pid -- Found installed package,
- -- replete with its version
- [] -> dep_pkgid -- No installed package; use
- -- the version-less one
-
-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
-- Check whether this package id already exists in this DB
--
when (not update && (pkgid `elem` map package pkgs)) $
- die ("package " ++ showPackageId pkgid ++ " is already installed")
+ die ("package " ++ display pkgid ++ " is already installed")
+
+ let
+ uncasep = map toLower . display
+ 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 " ++ display pkgid ++
+ " overlaps with: " ++ unwords (map display dups)
checkDir :: Force -> String -> IO ()
checkDir force d
- | "$topdir" `isPrefixOf` d = return ()
- -- can't check this, because we don't know what $topdir is
+ | "$topdir" `isPrefixOf` d = return ()
+ | "$httptopdir" `isPrefixOf` d = return ()
+ -- can't check these, because we don't know what $(http)topdir is
| otherwise = do
there <- doesDirectoryExist d
when (not there)
checkDep :: PackageDBStack -> Force -> PackageIdentifier -> IO ()
checkDep db_stack force pkgid
| pkgid `elem` pkgids || (not real_version && name_exists) = return ()
- | otherwise = dieOrForceAll force ("dependency " ++ showPackageId pkgid
+ | otherwise = dieOrForceAll force ("dependency " ++ display pkgid
++ " doesn't exist")
where
-- for backwards compat, we treat 0.0 as a special version,
doesLibExistIn :: String -> String -> IO Bool
doesLibExistIn lib d
- | "$topdir" `isPrefixOf` d = return True
+ | "$topdir" `isPrefixOf` d = return True
+ | "$httptopdir" `isPrefixOf` d = return True
| otherwise = doesFileExist (d ++ '/':lib)
checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO ()
#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
- [ OF_ListLocal ] -> listPackages new_flags 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
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 "")
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
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
+
+#if __GLASGOW_HASKELL__ <= 604
+isInfixOf :: (Eq a) => [a] -> [a] -> Bool
+isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)
+#endif
projects / ghc-hetmet.git / blobdiff