Ticket #1839: Main.hs.diff

utils/ghc-pkg/Main.hs

@@ -46 +46 @@
 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 +101 @@
   | FlagDefinedName String String
   | FlagSimpleOutput
   | FlagNamesOnly
+  | FlagBulkQueries
   deriving Eq
 
 flags :: [OptDescr Flag]
@@ -127 +129 @@
   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 +166 @@
   "  $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 +187 @@
   "  $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 +206 @@
 
 data Force = ForceAll | ForceFiles | NoForce
 
+data PackageArg = Id PackageIdentifier | Pattern String
+
 runit :: [Flag] -> [String] -> IO ()
 runit cli nonopts = do
   prog <- getProgramName
@@ -203 +218 @@
           | 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 +238 @@
         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 +471 @@
 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 +483 @@
 -- -----------------------------------------------------------------------------
 -- 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 +530 @@
           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 +552 @@
 -- -----------------------------------------------------------------------------
 -- 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 +588 @@
 -- -----------------------------------------------------------------------------
 -- 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 +994 @@
       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 +1004 @@
     [ 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)