From: Simon Marlow <marlowsd@gmail.com>
Date: Fri, 11 Jul 2008 12:17:39 +0000 (+0000)
Subject: add "ghc-pkg dump" (fixes #2201)
X-Git-Tag: Before_cabalised-GHC~21
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=58c73734b4397ac4ee635895b0a67a36514ef383

add "ghc-pkg dump" (fixes #2201)
---

diff --git a/docs/users_guide/packages.xml b/docs/users_guide/packages.xml
index 8f8f880..0d7a02f 100644
--- a/docs/users_guide/packages.xml
+++ b/docs/users_guide/packages.xml
@@ -613,6 +613,10 @@ c:/fptools/validate/ghc/driver/package.conf.inplace:
 	    <literal>InstalledPackageInfo</literal>, the same as the input file
 	    format for <literal>ghc-pkg register</literal>.  See <xref
 	      linkend="installed-pkg-info" /> for details.</para>
+
+          <para>If the pattern matches multiple packages, the
+            description for each package is emitted, separated by the
+            string <literal>---</literal> on a line by itself.</para>
 	</listitem>
       </varlistentry>
 
@@ -624,6 +628,23 @@ c:/fptools/validate/ghc/driver/package.conf.inplace:
       them with commas</para>
 	</listitem>
       </varlistentry>
+
+      <varlistentry>
+        <term><literal>ghc-pkg dump</literal></term>
+        <listitem>
+          <para>Emit the full description of every package, in the
+            form of an <literal>InstalledPackageInfo</literal>.
+            Multiple package descriptions are separated by the
+            string <literal>---</literal> on a line by itself.</para>
+
+          <para>This is almost the same as <literal>ghc-pkg describe '*'</literal>, except that <literal>ghc-pkg dump</literal>
+            is intended for use by tools that parse the results, so
+            for example where <literal>ghc-pkg describe '*'</literal>
+            will emit an error if it can't find any packages that
+            match the pattern, <literal>ghc-pkg dump</literal> will
+            simply emit nothing.</para>
+        </listitem>
+      </varlistentry>
     </variablelist>
 
     <para>
diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index a876243..f2087b9 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -189,6 +189,11 @@ usageHeader prog = substProg prog $
   "    Extract the specified field of the package description for the\n" ++
   "    specified package. Accepts comma-separated multiple fields.\n" ++
   "\n" ++
+  "  $p dump\n" ++
+  "    Dump the registered description for every package.  This is like\n" ++
+  "    \"ghc-pkg describe '*'\", except that it is intended to be used\n" ++
+  "    by tools that parse the results, rather than humans.\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" ++
@@ -304,6 +309,10 @@ runit cli nonopts = do
                                       (splitFields fields)
     ["check"] -> do
         checkConsistency cli
+
+    ["dump"] -> do
+        dumpPackages cli
+
     [] -> do
         die ("missing command\n" ++
                 usageInfo (usageHeader prog) flags)
@@ -351,6 +360,9 @@ type PackageDBStack = [(PackageDBName,PackageDB)]
         -- A stack of package databases.  Convention: head is the topmost
         -- in the stack.  Earlier entries override later one.
 
+allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
+allPackagesInStack = concatMap snd
+
 getPkgDatabases :: Bool -> [Flag] -> IO PackageDBStack
 getPkgDatabases modify flags = do
   -- first we determine the location of the global package config.  On Windows,
@@ -557,7 +569,7 @@ listPackages flags mPackageName mModuleName = do
 
       match `exposedInPkg` pkg = any match (map display $ exposedModules pkg)
 
-      pkg_map = map (\p -> (package p, p)) $ concatMap snd db_stack
+      pkg_map = map (\p -> (package p, p)) $ allPackagesInStack db_stack
       show_func = if simple_output then show_simple else mapM_ (show_normal pkg_map)
 
   show_func (reverse db_stack_sorted)
@@ -577,7 +589,7 @@ listPackages flags mPackageName mModuleName = do
           let showPkg = if FlagNamesOnly `elem` flags then display . pkgName
                                                       else display
               pkgs = map showPkg $ sortBy compPkgIdVer $
-                          map package (concatMap snd db_stack)
+                          map package (allPackagesInStack db_stack)
           when (not (null pkgs)) $ 
              hPutStrLn stdout $ concat $ intersperse " " pkgs
 
@@ -600,7 +612,15 @@ describePackage :: [Flag] -> PackageArg -> IO ()
 describePackage flags pkgarg = do
   db_stack <- getPkgDatabases False flags
   ps <- findPackages db_stack pkgarg
-  mapM_ (putStrLn . showInstalledPackageInfo) ps
+  doDump ps
+
+dumpPackages :: [Flag] -> IO ()
+dumpPackages flags = do
+  db_stack <- getPkgDatabases False flags
+  doDump (allPackagesInStack db_stack)
+
+doDump :: [InstalledPackageInfo] -> IO ()
+doDump = mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo
 
 -- PackageId is can have globVersion for the version
 findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
@@ -609,7 +629,7 @@ findPackages db_stack pkgarg
         []  -> die ("cannot find package " ++ pkg_msg pkgarg)
         ps -> return ps
   where
-        all_pkgs = concat (map snd db_stack)
+        all_pkgs = allPackagesInStack db_stack
         pkg_msg (Id pkgid)           = display pkgid
         pkg_msg (Substring pkgpat _) = "matching "++pkgpat
 
@@ -699,7 +719,7 @@ checkConsistency flags = do
   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
+  let pkgs = map (\p -> (package p, p)) $ allPackagesInStack db_stack
       broken_pkgs = do
         (pid, p) <- pkgs
         let broken_deps = missingPackageDeps p pkgs
@@ -875,7 +895,7 @@ checkDep db_stack force pkgid
         name_exists = any (\p -> pkgName (package p) == name) all_pkgs
         name = pkgName pkgid
 
-        all_pkgs = concat (map snd db_stack)
+        all_pkgs = allPackagesInStack db_stack
         pkgids = map package all_pkgs
 
 realVersion :: PackageIdentifier -> Bool