--- old-ghc-1/utils/ghc-pkg/Main.hs 2007-11-10 18:21:44.578125000 +0000 +++ new-ghc-1/utils/ghc-pkg/Main.hs 2007-11-10 18:21:44.578125000 +0000 @@ -46,7 +46,8 @@ 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, unfoldr, break ) +import Text.Regex #ifdef mingw32_HOST_OS import Foreign @@ -100,6 +101,7 @@ | FlagDefinedName String String | FlagSimpleOutput | FlagNamesOnly + | FlagBulkQueries deriving Eq flags :: [OptDescr Flag] @@ -127,7 +129,9 @@ 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 [] ["bulk"] (NoArg FlagBulkQueries) + "enable bulk queries" ] where toDefined str = @@ -162,7 +166,15 @@ " $p list [pkg]\n" ++ " List registered packages in the global database, and also the\n" ++ " user database if --user is given. If a package name is given\n" ++ - " all the registered versions will be listed in ascending order.\n" ++ + " All the registered versions will be listed in ascending order.\n" ++ + " Accepts package patterns if --bulk is given.\n" ++ + " Accepts the --simple-output flag.\n" ++ + "\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 module patterns if --bulk is given.\n" ++ " Accepts the --simple-output flag.\n" ++ "\n" ++ " $p latest pkg\n" ++ @@ -175,11 +187,12 @@ " $p describe {pkg-id}\n" ++ " Give the registered description for the specified package. The\n" ++ " description is returned in precisely the syntax required by $p\n" ++ - " register.\n" ++ + " register. Accepts package patterns if --bulk is given.\n" ++ "\n" ++ " $p field {pkg-id} {field}\n" ++ " Extract the specified field of the package description for the\n" ++ - " specified package.\n" ++ + " specified package. Accepts package patterns and comma-separated\n" ++ + " multiple fields if --bulk is given.\n" ++ "\n" ++ " The following optional flags are also accepted:\n" @@ -193,6 +206,8 @@ data Force = ForceAll | ForceFiles | NoForce +data PackageArg = Id PackageIdentifier | Pattern String + runit :: [Flag] -> [String] -> IO () runit cli nonopts = do prog <- getProgramName @@ -203,6 +218,9 @@ | 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) -- -- first, parse the command case nonopts of @@ -220,19 +238,27 @@ pkgid <- readGlobPkgId pkgid_str hidePackage pkgid cli ["list"] -> do - listPackages cli Nothing + listPackages cli Nothing Nothing + ["list", pkgid_pattern_str] | FlagBulkQueries `elem` cli -> do + listPackages cli (Just (Pattern pkgid_pattern_str)) Nothing ["list", pkgid_str] -> do pkgid <- readGlobPkgId pkgid_str - listPackages cli (Just pkgid) + listPackages cli (Just (Id pkgid)) Nothing + ["find-module", moduleName] -> do + listPackages cli Nothing (Just moduleName) ["latest", pkgid_str] -> do pkgid <- readGlobPkgId pkgid_str latestPackage cli pkgid + ["describe", pkgid_pattern_str] | FlagBulkQueries `elem` cli -> do + describePackage cli (Pattern pkgid_pattern_str) ["describe", pkgid_str] -> do pkgid <- readGlobPkgId pkgid_str - describePackage cli pkgid + describePackage cli (Id pkgid) + ["field", pkgid_pattern_str, fields] | FlagBulkQueries `elem` cli -> do + describeField cli (Pattern pkgid_pattern_str) (splitFields fields) ["field", pkgid_str, field] -> do pkgid <- readGlobPkgId pkgid_str - describeField cli pkgid field + describeField cli (Id pkgid) [field] ["check"] -> do checkConsistency cli [] -> do @@ -445,7 +471,7 @@ 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 @@ -457,14 +483,17 @@ -- ----------------------------------------------------------------------------- -- Listing packages -listPackages :: [Flag] -> Maybe PackageIdentifier -> IO () -listPackages flags mPackageName = do +listPackages :: [Flag] -> Maybe PackageArg -> 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 @@ -501,13 +530,20 @@ when (null pkgs) $ die "no matches" hPutStrLn stdout $ concat $ intersperse " " pkgs + exposedInPkg :: String -> InstalledPackageInfo -> Bool + moduleName `exposedInPkg` pkg | FlagBulkQueries `elem` flags + = any (isJust . (mkRegex moduleName `matchRegex`)) (exposedModules pkg) + moduleName `exposedInPkg` pkg + = moduleName `elem` exposedModules pkg + + -- ----------------------------------------------------------------------------- -- 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" @@ -516,28 +552,35 @@ -- ----------------------------------------------------------------------------- -- 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) = showPackageId pkgid + pkg_msg (Pattern 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 +pat_matches :: String -> PackageIdentifier -> Bool +pat `pat_matches` pid + = maybe False (const True) (mkRegex pat `matchRegex` pkgName pid) + +matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool +(Id pid) `matchesPkg` pkg = pid `matches` package pkg +(Pattern pat) `matchesPkg` pkg = pat `pat_matches` package pkg compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2 @@ -545,15 +588,19 @@ -- ----------------------------------------------------------------------------- -- 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 @@ -947,8 +994,8 @@ 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_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 @@ -957,10 +1004,10 @@ [ OF_Show pkgid_str ] | null fields -> do pkgid <- readPkgId pkgid_str - describePackage new_flags pkgid + describePackage new_flags (Id pkgid) | otherwise -> do pkgid <- readPkgId pkgid_str - mapM_ (describeField new_flags pkgid) fields + mapM_ (describeField new_flags (Id pkgid)) [fields] _ -> do prog <- getProgramName die (usageInfo (usageHeader prog) flags)