X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=d8b863938087ec61c1075f3d6911366cb4758f88;hp=bdd9c80893d28d56d97e1ab561ec8112b1b76d30;hb=60a826b1d835042e15c3d825f6a1baf310a8bb1b;hpb=107e84293bb60b82233b1177eae66ed33b665af1 diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index bdd9c80..d8b8639 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# OPTIONS -fglasgow-exts -cpp #-} ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow 2004. @@ -16,20 +16,15 @@ 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 @@ -42,13 +37,19 @@ import Data.Maybe import Data.Char ( isSpace, toLower ) import Control.Monad -import System.Directory ( doesDirectoryExist, getDirectoryContents, +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, nub ) +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 @@ -61,6 +62,11 @@ import System.Posix import IO ( isPermissionError, isDoesNotExistError ) +#if defined(GLOB) +import System.Process(runInteractiveCommand) +import qualified System.Info(os) +#endif + -- ----------------------------------------------------------------------------- -- Entry point @@ -95,6 +101,7 @@ data Flag | FlagAutoGHCiLibs | FlagSimpleOutput | FlagNamesOnly + | FlagIgnoreCase deriving Eq flags :: [OptDescr Flag] @@ -120,7 +127,9 @@ flags = [ 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] @@ -158,21 +167,31 @@ 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"++ @@ -198,6 +217,8 @@ substProg prog (c:xs) = c : substProg prog xs 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 @@ -208,9 +229,42 @@ runit cli nonopts = do | FlagForceFiles `elem` cli = ForceFiles | otherwise = NoForce auto_ghci_libs = FlagAutoGHCiLibs `elem` 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 cli auto_ghci_libs False force ["update", filename] -> @@ -226,20 +280,28 @@ runit cli nonopts = do hidePackage pkgid cli ["list"] -> do listPackages cli Nothing Nothing - ["list", pkgid_str] -> do - pkgid <- readGlobPkgId pkgid_str - listPackages cli (Just pkgid) 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 - listPackages cli Nothing (Just moduleName) + 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 @@ -260,7 +322,7 @@ readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier" parseGlobPackageId :: ReadP r PackageIdentifier parseGlobPackageId = - parsePackageId + parse +++ (do n <- parsePackageName; string "-*" return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion })) @@ -457,7 +519,7 @@ modifyPackage 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 @@ -469,7 +531,7 @@ modifyPackage fn pkgid flags = do -- ----------------------------------------------------------------------------- -- Listing packages -listPackages :: [Flag] -> Maybe PackageIdentifier -> Maybe String -> IO () +listPackages :: [Flag] -> Maybe PackageArg -> Maybe (String->Bool) -> IO () listPackages flags mPackageName mModuleName = do let simple_output = FlagSimpleOutput `elem` flags db_stack <- getPkgDatabases False flags @@ -477,8 +539,8 @@ listPackages flags mPackageName mModuleName = do | 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)) + | Just match <- mModuleName = -- packages which expose mModuleName + map (\(conf,pkgs) -> (conf, filter (match `exposedInPkg`) pkgs)) db_stack | otherwise = db_stack @@ -492,6 +554,8 @@ listPackages flags mPackageName mModuleName = do 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) @@ -506,11 +570,11 @@ listPackages flags mPackageName mModuleName = do | 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 (not (null pkgs)) $ @@ -522,56 +586,60 @@ listPackages flags mPackageName mModuleName = do 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 -exposedInPkg :: String -> InstalledPackageInfo -> Bool -moduleName `exposedInPkg` pkg = moduleName `elem` exposedModules pkg - -- ----------------------------------------------------------------------------- -- 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 strings "$topdir" and "$httptopdir" at the beginning of a path @@ -611,7 +679,7 @@ toField "hs_libraries" = Just $ strList . hsLibraries 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 @@ -641,22 +709,27 @@ checkConsistency flags = do 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 @@ -693,17 +766,16 @@ savingOldConfig filename io = Exception.block $ do `Exception.catch` \e -> do hPutStr stdout ("WARNING: an error was encountered while writing " ++ "the new configuration.\n") - if restore_on_error - then do + -- 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) - else do - -- file did not exist before, so the new one which - -- might be partially complete. - try (removeFile filename) - return () + -- Note the above renameFile sometimes fails on Windows with + -- "permission denied", I have no idea why --SDM. Exception.throwIO e ----------------------------------------------------------------------------- @@ -734,8 +806,8 @@ validatePackageConfig pkg db_stack auto_ghci_libs update force = do -- 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) @@ -749,16 +821,16 @@ checkDuplicates db_stack pkg update force = do -- 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 . showPackageId + 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 " ++ showPackageId pkgid ++ - " overlaps with: " ++ unwords (map showPackageId dups) + "Package " ++ display pkgid ++ + " overlaps with: " ++ unwords (map display dups) checkDir :: Force -> String -> IO () @@ -774,7 +846,7 @@ checkDir force d 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, @@ -991,3 +1063,8 @@ installSignalHandlers = do #else return () -- nothing #endif + +#if __GLASGOW_HASKELL__ <= 604 +isInfixOf :: (Eq a) => [a] -> [a] -> Bool +isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) +#endif