[project @ 2005-01-27 10:44:00 by simonpj]

[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 a3aa329..d6da914 100644 (file)
--- a/ghc/utils/ghc-pkg/Main.hs
+++ b/ghc/utils/ghc-pkg/Main.hs
@@ -25,7 +25,6 @@ import Compat.Directory       ( getAppUserDataDirectory, createDirectoryIfMissing )
 import Compat.RawSystem        ( rawSystem )
 import Control.Exception       ( evaluate )
 import qualified Control.Exception as Exception
-import System.FilePath         ( joinFileName )
 
 import Prelude
 
@@ -131,14 +130,15 @@ ourCopyright = "GHC package manager version " ++ version ++ "\n"
 usageHeader :: String -> String
 usageHeader prog = substProg prog $
   "Usage:\n" ++
-  "  $p {--help | -?}\n" ++
-  "    Produce this usage message.\n" ++
-  "\n" ++
-  "  $p register {filename | -} [--user | --global]\n" ++
+  "  $p register {filename | -}\n" ++
   "    Register the package using the specified installed package\n" ++
   "    description. The syntax for the latter is given in the $p\n" ++
   "    documentation.\n" ++
   "\n" ++
+  "  $p update {filename | -}\n" ++
+  "    Register the package, overwriting any other package with the\n" ++
+  "    same name.\n" ++
+  "\n" ++
   "  $p unregister {pkg-id}\n" ++
   "    Unregister the specified package.\n" ++
   "\n" ++
@@ -148,7 +148,7 @@ usageHeader prog = substProg prog $
   "  $p hide {pkg-id}\n" ++
   "    Hide the specified package.\n" ++
   "\n" ++
-  "  $p list [--global | --user]\n" ++
+  "  $p list\n" ++
   "    List all registered packages, both global and user (unless either\n" ++
   "    --global or --user is specified), and both hidden and exposed.\n" ++
   "\n" ++
@@ -159,7 +159,9 @@ usageHeader prog = substProg prog $
   "\n" ++
   "  $p field {pkg-id} {field}\n" ++
   "    Extract the specified field of the package description for the\n" ++
-  "    specified package.\n"
+  "    specified package.\n" ++
+  "\n" ++
+  " The following optional flags are also accepted:\n"
 
 substProg :: String -> String -> String
 substProg _ [] = []
@@ -307,7 +309,7 @@ registerPackage :: FilePath
                -> IO ()
 registerPackage input defines db_stack auto_ghci_libs update force = do
   let
-       db_to_operate_on = head db_stack
+       db_to_operate_on = my_head "db" db_stack
        db_filename      = fst db_to_operate_on
   --
   checkConfigAccess db_filename
@@ -539,7 +541,7 @@ checkDuplicates db_stack pkg update = do
   when (not update && exposed pkg && not (null exposed_pkgs_with_same_name)) $
        die ("trying to register " ++ showPackageId pkgid 
                  ++ " as exposed, but "
-                 ++ showPackageId (package (head exposed_pkgs_with_same_name))
+                 ++ showPackageId (package (my_head "when" exposed_pkgs_with_same_name))
                  ++ " is also exposed.")
 
 
@@ -631,9 +633,10 @@ updatePackageDB db_stack pkgs new_pkg = do
        resolveDep pkgid
           | realVersion pkgid  = pkgid
           | otherwise          = lookupDep (pkgName pkgid)
-       
+--        = pkgid
+
        lookupDep name
-          = head [ pid | p <- concat (map snd db_stack), 
+          = my_head "dep" [ pid | p <- concat (map snd db_stack), 
                          let pid = package p,
                          pkgName pid == name ]
 
@@ -766,7 +769,7 @@ oldRunit clis = do
 
   let auto_ghci_libs = any isAuto clis 
         where isAuto OF_AutoGHCiLibs = True; isAuto _ = False
-      input_file = head ([ f | (OF_Input f) <- clis] ++ ["-"])
+      input_file = my_head "inp" ([ f | (OF_Input f) <- clis] ++ ["-"])
 
       force = OF_Force `elem` clis
       
@@ -784,6 +787,9 @@ oldRunit clis = do
     _            -> do prog <- getProgramName
                       die (usageInfo (usageHeader prog) flags)
 
+my_head s [] = error s
+my_head s (x:xs) = x
+
 -- ---------------------------------------------------------------------------
 
 #ifdef OLD_STUFF
@@ -925,3 +931,45 @@ foreign import stdcall unsafe  "GetModuleFileNameA"
 getExecDir :: String -> IO (Maybe String) 
 getExecDir _ = return Nothing
 #endif
+
+-- -----------------------------------------------------------------------------
+-- FilePath utils
+
+-- | The 'joinFileName' function is the opposite of 'splitFileName'. 
+-- It joins directory and file names to form a complete file path.
+--
+-- The general rule is:
+--
+-- > dir `joinFileName` basename == path
+-- >   where
+-- >     (dir,basename) = splitFileName path
+--
+-- There might be an exceptions to the rule but in any case the
+-- reconstructed path will refer to the same object (file or directory).
+-- An example exception is that on Windows some slashes might be converted
+-- to backslashes.
+joinFileName :: String -> String -> FilePath
+joinFileName ""  fname = fname
+joinFileName "." fname = fname
+joinFileName dir ""    = dir
+joinFileName dir fname
+  | isPathSeparator (last dir) = dir++fname
+  | otherwise                  = dir++pathSeparator:fname
+
+-- | Checks whether the character is a valid path separator for the host
+-- platform. The valid character is a 'pathSeparator' but since the Windows
+-- operating system also accepts a slash (\"\/\") since DOS 2, the function
+-- checks for it on this platform, too.
+isPathSeparator :: Char -> Bool
+isPathSeparator ch = ch == pathSeparator || ch == '/'
+
+-- | Provides a platform-specific character used to separate directory levels in
+-- a path string that reflects a hierarchical file system organization. The
+-- separator is a slash (@\"\/\"@) on Unix and Macintosh, and a backslash
+-- (@\"\\\"@) on the Windows operating system.
+pathSeparator :: Char
+#ifdef mingw32_TARGET_OS
+pathSeparator = '\\'
+#else
+pathSeparator = '/'
+#endif