From: simonmar <unknown>
Date: Fri, 3 Dec 2004 13:57:19 +0000 (+0000)
Subject: [project @ 2004-12-03 13:57:19 by simonmar]
X-Git-Tag: Initial_conversion_from_CVS_complete~1364
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=e0ccc77e839b7150a731301046f7488078b241f9;p=ghc-hetmet.git

[project @ 2004-12-03 13:57:19 by simonmar]
- Implement expose/hide
- fix parsing of package identifiers (forgot to commit this the other day)
---

diff --git a/ghc/utils/ghc-pkg/Main.hs b/ghc/utils/ghc-pkg/Main.hs
index c9dd5d4..466806a 100644
--- a/ghc/utils/ghc-pkg/Main.hs
+++ b/ghc/utils/ghc-pkg/Main.hs
@@ -188,7 +188,7 @@ runit cli nonopts = do
 	registerPackage filename [] db_stack auto_ghci_libs True force
     ["unregister", pkgid_str] -> do
 	pkgid <- readPkgId pkgid_str
-	unregisterPackage db_stack pkgid
+	unregisterPackage pkgid db_stack
     ["expose", pkgid_str] -> do
 	pkgid <- readPkgId pkgid_str
 	exposePackage pkgid db_stack
@@ -212,8 +212,8 @@ runit cli nonopts = do
 
 parseCheck :: ReadP a a -> String -> String -> IO a
 parseCheck parser str what = 
-  case readP_to_S parser str of
-    [(x,ys)] | all isSpace ys -> return x
+  case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of
+    [x] -> return x
     _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)
 
 readPkgId :: String -> IO PackageIdentifier
@@ -348,29 +348,34 @@ pkgNameToId :: String -> PackageIdentifier
 pkgNameToId name = PackageIdentifier name (Version [] [])
 
 -- -----------------------------------------------------------------------------
--- Unregistering
+-- Exposing, Hiding, Unregistering are all similar
 
-unregisterPackage :: PackageDBStack -> PackageIdentifier -> IO ()
-unregisterPackage [] _ = error "unregisterPackage"
-unregisterPackage ((db_name, pkgs) : _) pkgid = do  
+exposePackage :: PackageIdentifier ->  PackageDBStack -> IO ()
+exposePackage = modifyPackage (\p -> [p{exposed=True}])
+
+hidePackage :: PackageIdentifier ->  PackageDBStack -> IO ()
+hidePackage = modifyPackage (\p -> [p{exposed=False}])
+
+unregisterPackage :: PackageIdentifier ->  PackageDBStack -> IO ()
+unregisterPackage = modifyPackage (\p -> [])
+
+modifyPackage
+  :: (InstalledPackageInfo -> [InstalledPackageInfo])
+  -> PackageIdentifier
+  -> PackageDBStack
+  -> IO ()
+modifyPackage _ _ [] = error "modifyPackage"
+modifyPackage fn pkgid ((db_name, pkgs) : _) = do
   checkConfigAccess db_name
   p <- findPackage [(db_name,pkgs)] pkgid
   let pid = package p
   savePackageConfig db_name
+  let new_config = concat (map modify pkgs)
+      modify pkg
+	| package pkg == pid = fn pkg
+	| otherwise          = [pkg]
   maybeRestoreOldConfig db_name $
-    writeNewConfig db_name (filter ((/= pid) . package) pkgs)
-
--- -----------------------------------------------------------------------------
--- Exposing
-
-exposePackage :: PackageIdentifier ->  PackageDBStack -> IO ()
-exposePackage = error "TODO"
-
--- -----------------------------------------------------------------------------
--- Hiding
-
-hidePackage :: PackageIdentifier ->  PackageDBStack -> IO ()
-hidePackage = error "TODO"
+    writeNewConfig db_name new_config
 
 -- -----------------------------------------------------------------------------
 -- Listing packages
@@ -774,7 +779,7 @@ oldRunit clis = do
     [ OF_ListLocal ] -> listPackages db_stack
     [ OF_Add upd ]   -> registerPackage input_file defines db_stack
 				auto_ghci_libs upd force
-    [ OF_Remove p ]  -> unregisterPackage db_stack (pkgNameToId p)
+    [ OF_Remove p ]  -> unregisterPackage (pkgNameToId p) db_stack
     [ OF_Show p ]
 	| null fields -> describePackage db_stack (pkgNameToId p)
 	| otherwise   -> mapM_ (describeField db_stack (pkgNameToId p)) fields