[project @ 2001-03-27 14:10:34 by simonmar]

- add --show-package option to display the config info for a particular
  package.

- add --field info, for use with --show-package, which displays the
  contents of the given field in the package config only.  The field
  is displayed one string per line.

diff --git a/ghc/utils/ghc-pkg/Main.hs b/ghc/utils/ghc-pkg/Main.hs
index f126609..139ce87 100644 (file)
--- a/ghc/utils/ghc-pkg/Main.hs
+++ b/ghc/utils/ghc-pkg/Main.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.7 2001/03/27 13:38:03 simonmar Exp $
+-- $Id: Main.hs,v 1.8 2001/03/27 14:10:34 simonmar Exp $
 --
 -- Package management tool
 -----------------------------------------------------------------------------
@@ -26,9 +26,10 @@ main = do
        (_,_,errors) -> die (concat errors ++ 
                             usageInfo usageHeader flags)
 
-data Flag = Config String | List | Add | Remove String
-isConfig (Config _) = True
-isConfig _ = False
+data Flag = Config String | List | Add | Remove String | Show String | Field String
+isConfigOrField (Config _) = True
+isConfigOrField (Field _) = True
+isConfigOrField _ = False
 
 usageHeader = "ghc-pkg [OPTION...]"
 
@@ -39,6 +40,10 @@ flags = [
        "List the currently installed packages",
   Option ['a'] ["add-package"] (NoArg Add)
        "Add a new package",
+  Option ['s'] ["show-package"] (ReqArg Show "NAME")
+       "Show the configuration for package NAME",
+  Option [] ["field"] (ReqArg Field "FIELD")
+       "(with --show-package) Show field FIELD only",
   Option ['r'] ["remove-package"] (ReqArg Remove "NAME")
        "Remove an installed package"
   ]
@@ -50,14 +55,30 @@ runit clis = do
         [f] -> return f
         _   -> die (usageInfo usageHeader flags)
 
+  let toField "import_dirs"     = return import_dirs
+      toField "source_dirs"     = return source_dirs
+      toField "library_dirs"    = return library_dirs
+      toField "hs_libraries"    = return hs_libraries
+      toField "extra_libraries" = return extra_libraries
+      toField "include_dirs"    = return include_dirs
+      toField "c_includes"      = return c_includes
+      toField "package_deps"    = return package_deps
+      toField "extra_ghc_opts"  = return extra_ghc_opts
+      toField "extra_cc_opts"   = return extra_cc_opts
+      toField "extra_ld_opts"   = return extra_ld_opts  
+      toField s                        = die ("unknown field: `" ++ s ++ "'")
+
+  fields <- mapM toField [ f | Field f <- clis ]
+
   s <- readFile conf_file
   let details = read s :: [PackageConfig]
   eval_catch details (\_ -> die "parse error in package config file")
 
-  case [ c | c <- clis, not (isConfig c) ] of
+  case [ c | c <- clis, not (isConfigOrField c) ] of
     [ List ]     -> listPackages details
     [ Add  ]     -> addPackage details conf_file
     [ Remove p ] -> removePackage details conf_file p
+    [ Show p ]   -> showPackage details conf_file p fields
     _            -> die (usageInfo usageHeader flags)
 
 
@@ -67,6 +88,16 @@ listPackages details = do
   hPutChar stdout '\n'
   exitWith ExitSuccess
 
+showPackage :: [PackageConfig] -> FilePath -> String
+        -> [PackageConfig->[String]] -> IO ()
+showPackage details pkgconf pkg_name fields =
+  case [ p | p <- details, name p == pkg_name ] of
+    []    -> die ("can't find package `" ++ pkg_name ++ "'")
+    [pkg] | null fields -> hPutStrLn stdout (render (dumpPkgGuts pkg))
+         | otherwise   -> hPutStrLn stdout (render (vcat 
+                               (map (vcat . map text) (map ($pkg) fields))))
+    _     -> die "showPackage: internal error"
+
 addPackage :: [PackageConfig] -> FilePath -> IO ()
 addPackage details pkgconf = do
   checkConfigAccess pkgconf

diff --git a/ghc/utils/ghc-pkg/Package.hs b/ghc/utils/ghc-pkg/Package.hs
index 51a8a93..ae330ab 100644 (file)
--- a/ghc/utils/ghc-pkg/Package.hs
+++ b/ghc/utils/ghc-pkg/Package.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: Package.hs,v 1.1 2001/03/15 15:51:38 simonmar Exp $
+-- $Id: Package.hs,v 1.2 2001/03/27 14:10:34 simonmar Exp $
 --
 -- Package configuration defn.
 -----------------------------------------------------------------------------
@@ -8,8 +8,10 @@
 module Package ( 
        PackageConfig(..), defaultPackageConfig
 #ifdef WANT_PRETTY
-       ,listPkgs       -- :: [PackageConfig] -> String
-       ,dumpPackages   -- :: [PackageConfig] -> String
+       , listPkgs              -- :: [PackageConfig] -> String
+       , dumpPackages          -- :: [PackageConfig] -> String
+       , dumpPkgGuts           -- :: PackageConfig -> Doc
+       , dumpFieldContents     -- :: [String] -> Doc
 #endif
  ) where
 #endif
@@ -83,8 +85,9 @@ dumpPkgGuts pkg =
       ])))
 
 dumpField :: String -> [String] -> Doc
-dumpField name val =
-   hang (text name <+> equals) 2
-        (brackets (sep (punctuate comma (map (text . show) val))))
+dumpField name val = hang (text name <+> equals) 2  (dumpFieldContents val)
+
+dumpFieldContents :: [String] -> Doc
+dumpFieldContents val = brackets (sep (punctuate comma (map (text . show) val)))
 #endif