[project @ 2001-08-21 09:03:32 by rrt]

[ghc-hetmet.git] / ghc / utils / ghc-pkg / Main.hs

diff --git a/ghc/utils/ghc-pkg/Main.hs b/ghc/utils/ghc-pkg/Main.hs
index 6ff2055..9d922e9 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.2 2001/03/16 10:04:31 simonmar Exp $
+-- $Id: Main.hs,v 1.13 2001/08/21 09:03:32 rrt Exp $
 --
 -- Package management tool
 -----------------------------------------------------------------------------
@@ -18,7 +18,11 @@ import Directory
 import System
 import IO
 
-default_pkgconf = clibdir ++ "/package.conf"
+#include "../includes/config.h"
+
+#ifdef mingw32_TARGET_OS
+import Win32DLL
+#endif
 
 main = do
   args <- getArgs
@@ -28,9 +32,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...]"
 
@@ -41,25 +46,58 @@ 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"
   ]
 
+#ifdef mingw32_TARGET_OS
+subst a b ls = map (\ x -> if x == a then b else x) ls
+
+unDosifyPath xs = subst '\\' '/' xs
+#endif
+
 runit clis = do
   conf_file <- 
      case [ f | Config f <- clis ] of
-        []  -> return default_pkgconf
-        [f] -> return f
-        _   -> die (usageInfo usageHeader flags)
+        fs@(_:_)  -> return (last fs)
+#ifndef mingw32_TARGET_OS
+       [] -> die "missing -f option, location of package.conf unknown"
+#else
+       [] -> do h <- getModuleHandle Nothing
+                n <- getModuleFileName h
+--              return (reverse (tail (dropWhile (not . isSlash) 
+                return (reverse (drop (length "/bin/ghc-pkg.exe") (reverse (unDosifyPath n))) ++ "/package.conf")
+--                        (reverse (unDosifyPath n)))) ++ "/package.conf")
+#endif
+
+  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,7 +105,16 @@ listPackages :: [PackageConfig] -> IO ()
 listPackages details = do 
   hPutStr stdout (listPkgs details)
   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
@@ -81,9 +128,8 @@ addPackage details pkgconf = do
        then die ("package `" ++ name new_pkg ++ "' already installed")
        else do
   savePackageConfig pkgconf
-  maybeRestoreOldConfig pkgconf $ do
-  writeNewConfig pkgconf (details ++ [new_pkg])
-  exitWith ExitSuccess
+  maybeRestoreOldConfig pkgconf $
+    writeNewConfig pkgconf (details ++ [new_pkg])
 
 removePackage :: [PackageConfig] -> FilePath -> String -> IO ()
 removePackage details pkgconf pkg = do  
@@ -92,9 +138,8 @@ removePackage details pkgconf pkg = do
        then die ("package `" ++ pkg ++ "' not installed")
        else do
   savePackageConfig pkgconf
-  maybeRestoreOldConfig pkgconf $ do
-  writeNewConfig pkgconf (filter ((/= pkg) . name) details)
-  exitWith ExitSuccess
+  maybeRestoreOldConfig pkgconf $
+    writeNewConfig pkgconf (filter ((/= pkg) . name) details)
 
 checkConfigAccess :: FilePath -> IO ()
 checkConfigAccess pkgconf = do
@@ -117,7 +162,7 @@ writeNewConfig :: String -> [PackageConfig] -> IO ()
 writeNewConfig conf_file details = do
   hPutStr stdout "Writing new package config file... "
   h <- openFile conf_file WriteMode
-  hPutStr h (dumpPackages details )
+  hPutStrLn h (dumpPackages details)
   hClose h
   hPutStrLn stdout "done."