X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=feb88cb2d261c544dc19266002dbc61fd867a532;hb=dd9d5b34eb64fd45b362eab8aed53b90f1defeec;hp=1d2620894f79199682765187e211c12714f75211;hpb=536eaecd1071cfd25e0384b10ed9b72f98b21f46;p=ghc-hetmet.git diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 1d26208..feb88cb 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -40,13 +40,13 @@ import Text.PrettyPrint import qualified Control.Exception as Exception import Data.Maybe -import Data.Char ( isSpace ) +import Data.Char ( isSpace, toLower ) import Monad import Directory import System ( getArgs, getProgName, getEnv, exitWith, ExitCode(..) ) import System.IO import System.IO.Error (try) -import Data.List ( isPrefixOf, isSuffixOf, intersperse, sortBy ) +import Data.List ( isPrefixOf, isSuffixOf, intersperse, sortBy, nub ) #ifdef mingw32_HOST_OS import Foreign @@ -70,17 +70,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 +87,6 @@ data Flag | FlagForce | FlagForceFiles | FlagAutoGHCiLibs - | FlagDefinedName String String | FlagSimpleOutput | FlagNamesOnly deriving Eq @@ -107,9 +96,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,14 +119,8 @@ 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" @@ -185,6 +168,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 @@ -206,14 +201,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 +248,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" @@ -343,29 +334,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 @@ -386,13 +388,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,12 +409,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." - 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 @@ -422,9 +422,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 @@ -621,7 +620,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 @@ -705,7 +706,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) @@ -727,42 +728,8 @@ checkPackageId ipi = [] -> die ("invalid package identifier: " ++ str) _ -> die ("ambiguous package identifier: " ++ str) --- ToDo: remove this (see #1837) -resolveDeps :: PackageDBStack -> InstalledPackageInfo -> IO InstalledPackageInfo -resolveDeps db_stack p = do - when (not (null unversioned_deps)) $ - hPutStr stderr ("WARNING: unversioned dependencies are deprecated, "++ - "and will NOT be accepted by GHC 6.10: " ++ - unwords (map showPackageId unversioned_deps) ++ "\n") - return (updateDeps p) - where - unversioned_deps = filter (not.realVersion) (depends p) - - -- 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 @@ -772,6 +739,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 () @@ -886,114 +861,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 @@ -1005,9 +877,6 @@ 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) (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++ show nm) @@ -1046,6 +915,10 @@ 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