X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=f2087b979b01b2c8bdcb49ac009dc4a679bacdb2;hb=58c73734b4397ac4ee635895b0a67a36514ef383;hp=d8b863938087ec61c1075f3d6911366cb4758f88;hpb=60a826b1d835042e15c3d825f6a1baf310a8bb1b;p=ghc-hetmet.git

diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index d8b8639..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)
@@ -324,7 +333,8 @@ parseGlobPackageId :: ReadP r PackageIdentifier
 parseGlobPackageId =
   parse
      +++
-  (do n <- parsePackageName; string "-*"
+  (do n <- parse
+      string "-*"
       return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
 
 -- globVersion means "all versions"
@@ -350,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,
@@ -444,7 +457,7 @@ getPkgDatabases modify flags = do
 readParseDatabase :: PackageDBName -> IO (PackageDBName,PackageDB)
 readParseDatabase filename = do
   str <- readFile filename `Exception.catch` \_ -> return emptyPackageConfig
-  let packages = read str
+  let packages = map convertPackageInfoIn $ read str
   Exception.evaluate packages
     `Exception.catch` \e->
         die ("error while parsing " ++ filename ++ ": " ++ show e)
@@ -554,9 +567,9 @@ 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)
+      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)
@@ -573,10 +586,10 @@ listPackages flags mPackageName mModuleName = do
                    where doc = text (display (package p))
 
         show_simple db_stack = do
-          let showPkg = if FlagNamesOnly `elem` flags then pkgName
+          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
 
@@ -599,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]
@@ -608,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
 
@@ -698,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
@@ -734,6 +755,23 @@ isBrokenPackage pkg pkg_map
 -- -----------------------------------------------------------------------------
 -- Manipulating package.conf files
 
+type InstalledPackageInfoString = InstalledPackageInfo_ String
+
+convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString
+convertPackageInfoOut
+    (pkgconf@(InstalledPackageInfo { exposedModules = e,
+                                     hiddenModules = h })) =
+        pkgconf{ exposedModules = map display e,
+                 hiddenModules  = map display h }
+
+convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo
+convertPackageInfoIn
+    (pkgconf@(InstalledPackageInfo { exposedModules = e,
+                                     hiddenModules = h })) =
+        pkgconf{ exposedModules = map convert e,
+                 hiddenModules  = map convert h }
+    where convert = fromJust . simpleParse
+
 writeNewConfig :: FilePath -> [InstalledPackageInfo] -> IO ()
 writeNewConfig filename packages = do
   hPutStr stdout "Writing new package config file... "
@@ -742,7 +780,8 @@ writeNewConfig filename packages = do
       if isPermissionError e
       then die (filename ++ ": you don't have permission to modify this file")
       else ioError e
-  let shown = concat $ intersperse ",\n " $ map show packages
+  let shown = concat $ intersperse ",\n "
+                     $ map (show . convertPackageInfoOut) packages
       fileContents = "[" ++ shown ++ "\n]"
   hPutStrLn h fileContents
   hClose h
@@ -856,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