X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=697816eb099f86ab95549b5c03b5587da1ec0fa4;hp=17531113ad4af1d72c1ce419572a53f754b46079;hb=32b906efc4c6474d8af6fd7be2a3ddac2ae20a16;hpb=8f4c823a0a5f8d730eff0fc2ee5e12cb248c0caa diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 1753111..697816e 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -21,6 +21,7 @@ import Distribution.Compat.ReadP import Distribution.ParseUtils import Distribution.Package import Distribution.Version +import System.FilePath #ifdef USING_COMPAT import Compat.Directory ( getAppUserDataDirectory, createDirectoryIfMissing ) @@ -39,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 ) @@ -61,7 +68,7 @@ main :: IO () 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) @@ -69,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) @@ -96,8 +93,8 @@ data Flag | FlagForce | FlagForceFiles | FlagAutoGHCiLibs - | FlagDefinedName String String | FlagSimpleOutput + | FlagNamesOnly deriving Eq flags :: [OptDescr Flag] @@ -105,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) @@ -118,21 +115,21 @@ flags = [ "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" + "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" + ] + +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 $ @@ -177,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 @@ -191,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 @@ -198,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 @@ -216,10 +225,12 @@ runit cli nonopts = do pkgid <- readGlobPkgId pkgid_str hidePackage pkgid cli ["list"] -> do - listPackages cli Nothing + listPackages cli Nothing Nothing ["list", pkgid_str] -> do pkgid <- readGlobPkgId pkgid_str - listPackages cli (Just pkgid) + listPackages cli (Just pkgid) Nothing + ["find-module", moduleName] -> do + listPackages cli Nothing (Just moduleName) ["latest", pkgid_str] -> do pkgid <- readGlobPkgId pkgid_str latestPackage cli pkgid @@ -244,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" @@ -292,7 +300,7 @@ getPkgDatabases modify flags = do [] -> do mb_dir <- getExecDir "/bin/ghc-pkg.exe" case mb_dir of Nothing -> die err_msg - Just dir -> return (dir `joinFileName` "package.conf") + Just dir -> return (dir "package.conf") fs -> return (last fs) let global_conf_dir = global_conf ++ ".d" @@ -309,9 +317,9 @@ getPkgDatabases modify flags = do appdir <- getAppUserDataDirectory "ghc" let - subdir = targetARCH ++ '-':targetOS ++ '-':version - archdir = appdir `joinFileName` subdir - user_conf = archdir `joinFileName` "package.conf" + subdir = targetARCH ++ '-':targetOS ++ '-':Version.version + archdir = appdir subdir + user_conf = archdir "package.conf" user_exists <- doesFileExist user_conf -- If the user database doesn't exist, and this command isn't a @@ -320,42 +328,53 @@ 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 Right path | last cs == "" -> init cs ++ sys_databases | otherwise -> cs - where cs = parseSearchPath path + where cs = splitSearchPath path -- The "global" database is always the one at the bottom of the stack. -- 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 @@ -365,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 @@ -376,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 @@ -398,12 +416,11 @@ 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 - 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 @@ -412,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 @@ -453,14 +469,17 @@ modifyPackage fn pkgid flags = do -- ----------------------------------------------------------------------------- -- Listing packages -listPackages :: [Flag] -> Maybe PackageIdentifier -> IO () -listPackages flags mPackageName = do +listPackages :: [Flag] -> Maybe PackageIdentifier -> Maybe String -> 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 this <- mModuleName = -- packages which expose mModuleName + map (\(conf,pkgs) -> (conf, filter (this `exposedInPkg`) pkgs)) + db_stack | otherwise = db_stack db_stack_sorted @@ -490,10 +509,12 @@ listPackages flags mPackageName = do where doc = text (showPackageId (package p)) show_simple db_stack = do - let pkgs = map showPackageId $ sortBy compPkgIdVer $ + let showPkg = if FlagNamesOnly `elem` flags then pkgName + 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 @@ -536,6 +557,9 @@ pid `matchesPkg` pkg = pid `matches` package pkg compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2 +exposedInPkg :: String -> InstalledPackageInfo -> Bool +moduleName `exposedInPkg` pkg = moduleName `elem` exposedModules pkg + -- ----------------------------------------------------------------------------- -- Field @@ -546,11 +570,11 @@ describeField flags pkgid field = do Nothing -> die ("unknown field: " ++ field) Just fn -> do ps <- findPackages db_stack pkgid - let top_dir = getFilenameDir (fst (last db_stack)) + let top_dir = takeDirectory (fst (last db_stack)) mapM_ (putStrLn . fn) (mungePackagePaths top_dir ps) 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 @@ -565,8 +589,11 @@ mungePackagePaths top_dir ps = map munge_pkg ps 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 @@ -600,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 @@ -635,7 +664,7 @@ isBrokenPackage pkg pkg_map = not . null $ missingPackageDeps pkg pkg_map writeNewConfig :: FilePath -> [InstalledPackageInfo] -> IO () writeNewConfig filename packages = do hPutStr stdout "Writing new package config file... " - createDirectoryIfMissing True $ getFilenameDir filename + createDirectoryIfMissing True $ takeDirectory filename h <- openFile filename WriteMode `catch` \e -> if isPermissionError e then die (filename ++ ": you don't have permission to modify this file") @@ -660,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 @@ -684,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) @@ -706,34 +739,8 @@ checkPackageId ipi = [] -> 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 @@ -743,12 +750,21 @@ 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 () 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) @@ -784,7 +800,8 @@ checkHSLib dirs auto_ghci_libs force lib = do 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 () @@ -837,7 +854,7 @@ searchEntries path prefix (f:fs) ms <- searchEntries path prefix fs return (prefix `joinModule` f : ms) | looks_like_a_component = do - ms <- searchDir (path `joinFilename` f) (prefix `joinModule` f) + ms <- searchDir (path f) (prefix `joinModule` f) ms' <- searchEntries path prefix fs return (ms ++ ms') | otherwise @@ -855,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 - [ 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 @@ -974,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 "") @@ -1015,11 +926,18 @@ 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 subst a b ls = map (\ x -> if x == a then b else x) ls + +unDosifyPath :: FilePath -> FilePath unDosifyPath xs = subst '\\' '/' xs getExecDir :: String -> IO (Maybe String) @@ -1044,80 +962,31 @@ getExecDir :: String -> IO (Maybe String) getExecDir _ = return Nothing #endif --- ----------------------------------------------------------------------------- --- FilePath utils - --- | The 'joinFileName' function is the opposite of 'splitFileName'. --- It joins directory and file names to form a complete file path. --- --- The general rule is: --- --- > dir `joinFileName` basename == path --- > where --- > (dir,basename) = splitFileName path --- --- There might be an exceptions to the rule but in any case the --- reconstructed path will refer to the same object (file or directory). --- An example exception is that on Windows some slashes might be converted --- to backslashes. -joinFileName :: String -> String -> FilePath -joinFileName "" fname = fname -joinFileName "." fname = fname -joinFileName dir "" = dir -joinFileName dir fname - | isPathSeparator (last dir) = dir++fname - | otherwise = dir++pathSeparator:fname - --- | Checks whether the character is a valid path separator for the host --- platform. The valid character is a 'pathSeparator' but since the Windows --- operating system also accepts a slash (\"\/\") since DOS 2, the function --- checks for it on this platform, too. -isPathSeparator :: Char -> Bool -isPathSeparator ch = ch == pathSeparator || ch == '/' - --- | Provides a platform-specific character used to separate directory levels in --- a path string that reflects a hierarchical file system organization. The --- separator is a slash (@\"\/\"@) on Unix and Macintosh, and a backslash --- (@\"\\\"@) on the Windows operating system. -pathSeparator :: Char -#ifdef mingw32_HOST_OS -pathSeparator = '\\' -#else -pathSeparator = '/' -#endif - -getFilenameDir :: FilePath -> FilePath -getFilenameDir fn = case break isPathSeparator (reverse fn) of - (xs, "") -> "." - (_, sep:ys) -> reverse ys - --- | The function splits the given string to substrings --- using the 'searchPathSeparator'. -parseSearchPath :: String -> [FilePath] -parseSearchPath path = split path - where - split :: String -> [String] - split s = - case rest' of - [] -> [chunk] - _:rest -> chunk : split rest - where - chunk = - case chunk' of -#ifdef mingw32_HOST_OS - ('\"':xs@(_:_)) | last xs == '\"' -> init xs -#endif - _ -> chunk' - - (chunk', rest') = break (==searchPathSeparator) s +----------------------------------------- +-- Adapted from ghc/compiler/utils/Panic --- | A platform-specific character used to separate search path strings --- in environment variables. The separator is a colon (\":\") on Unix --- and Macintosh, and a semicolon (\";\") on the Windows operating system. -searchPathSeparator :: Char -#if mingw32_HOST_OS || mingw32_TARGET_OS -searchPathSeparator = ';' +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 -searchPathSeparator = ':' + return () -- nothing #endif -