[project @ 2004-12-03 16:25:58 by simonmar]

[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 964678c..880bc4b 100644 (file)
--- a/ghc/utils/ghc-pkg/Main.hs
+++ b/ghc/utils/ghc-pkg/Main.hs
@@ -104,6 +104,7 @@ data Flag
   | FlagConfig FilePath
   | FlagGlobalConfig FilePath
   | FlagForce
+  | FlagAutoGHCiLibs
   deriving Eq
 
 flags :: [OptDescr Flag]
@@ -118,6 +119,8 @@ flags = [
        "location of the global package config",
   Option [] ["force"] (NoArg FlagForce)
        "ignore missing dependencies, directories, and libraries",
+  Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
+       "automatically build libs for GHCi (with register)",
   Option ['?'] ["help"] (NoArg FlagHelp)
        "display this help and exit",
    Option ['V'] ["version"] (NoArg FlagVersion)
@@ -175,16 +178,17 @@ runit cli nonopts = do
   db_stack <- mapM readParseDatabase dbs
   let
        force = FlagForce `elem` cli
+       auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
   --
   -- first, parse the command
   case nonopts of
     ["register", filename] -> 
-       registerPackage filename [] db_stack False False force
+       registerPackage filename [] db_stack auto_ghci_libs False force
     ["update", filename] -> 
-       registerPackage filename [] db_stack False True force
+       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
@@ -208,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
@@ -344,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
@@ -565,8 +574,8 @@ checkHSLib dirs auto_ghci_libs force lib = do
   let batch_lib_file = "lib" ++ lib ++ ".a"
   bs <- mapM (doesLibExistIn batch_lib_file) dirs
   case [ dir | (exists,dir) <- zip bs dirs, exists ] of
-       [] -> dieOrForce force ("cannot find `" ++ batch_lib_file ++
-                                "' on library path") 
+       [] -> dieOrForce force ("cannot find " ++ batch_lib_file ++
+                                " on library path") 
        (dir:_) -> checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs
 
 doesLibExistIn :: String -> String -> IO Bool
@@ -580,7 +589,7 @@ checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build
   | otherwise  = do
       bs <- mapM (doesLibExistIn ghci_lib_file) dirs
       case [dir | (exists,dir) <- zip bs dirs, exists] of
-        []    -> hPutStrLn stderr ("warning: can't find GHCi lib `" ++ ghci_lib_file ++ "'")
+        []    -> hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file)
        (_:_) -> return ()
   where
     ghci_lib_file = lib ++ ".o"
@@ -592,7 +601,7 @@ autoBuildGHCiLib :: String -> String -> String -> IO ()
 autoBuildGHCiLib dir batch_file ghci_file = do
   let ghci_lib_file  = dir ++ '/':ghci_file
       batch_lib_file = dir ++ '/':batch_file
-  hPutStr stderr ("building GHCi library `" ++ ghci_lib_file ++ "'...")
+  hPutStr stderr ("building GHCi library " ++ ghci_lib_file ++ "...")
 #if defined(darwin_TARGET_OS)
   r <- system("ld -r -x -o " ++ ghci_lib_file ++ 
                 " -all_load " ++ batch_lib_file)
@@ -770,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