X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Futils%2Fghc-pkg%2FMain.hs;h=1b5f8f75dd509843bc5d01a9c6cda1cb3822b63d;hb=153b9cb9b11e05c4edb1b6bc0a7b972660e41f70;hp=a3aa329de4fa2f58fb261c77e3d243877b1a9f02;hpb=f6072cc4e89e50de957607e82bea904659014548;p=ghc-hetmet.git

diff --git a/ghc/utils/ghc-pkg/Main.hs b/ghc/utils/ghc-pkg/Main.hs
index a3aa329..1b5f8f7 100644
--- a/ghc/utils/ghc-pkg/Main.hs
+++ b/ghc/utils/ghc-pkg/Main.hs
@@ -25,13 +25,10 @@ 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
 
-#if __GLASGOW_HASKELL__ < 603
-#include "config.h"
-#endif
+#include "../../includes/ghcconfig.h"
 
 #if __GLASGOW_HASKELL__ >= 504
 import System.Console.GetOpt
@@ -52,7 +49,7 @@ import System	( getArgs, getProgName,
 import System.IO
 import Data.List ( isPrefixOf, isSuffixOf, intersperse )
 
-#ifdef mingw32_TARGET_OS
+#ifdef mingw32_HOST_OS
 import Foreign
 
 #if __GLASGOW_HASKELL__ >= 504
@@ -131,14 +128,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 +146,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 +157,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 +307,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 +539,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.")
 
 
@@ -603,7 +603,7 @@ 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 ++ "...")
-#if defined(darwin_TARGET_OS)
+#if defined(darwin_HOST_OS)
   r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
 #elif defined(mingw32_HOST_OS)
   execDir <- getExecDir "/bin/ghc-pkg.exe"
@@ -624,18 +624,28 @@ updatePackageDB
 	-> IO [InstalledPackageInfo]
 updatePackageDB db_stack pkgs new_pkg = do
   let
-	-- we update dependencies without version numbers to
-	-- match the actual versions of the relevant packages instaled.
+	-- The input package spec is allowed to give a package dependency
+	-- without a version number; e.g.
+	--	depends: base
+	-- Here, we update these dependencies without version numbers to
+	-- match the actual versions of the relevant packages installed.
 	updateDeps p = p{depends = map resolveDep (depends p)}
 
-	resolveDep pkgid
-	   | realVersion pkgid  = pkgid
-	   | otherwise		= lookupDep (pkgName pkgid)
-	
-	lookupDep name
-	   = head [ pid | p <- concat (map snd db_stack), 
+	resolveDep dep_pkgid
+	   | realVersion dep_pkgid  = dep_pkgid
+	   | otherwise		    = lookupDep dep_pkgid
+
+	lookupDep dep_pkgid
+	   = let 
+		name = pkgName dep_pkgid
+	     in
+	     case [ pid | p <- concat (map snd db_stack), 
 			  let pid = package p,
-			  pkgName pid == name ]
+			  pkgName pid == name ] of
+		(pid:_) -> pid		-- Found installed package,
+					-- replete with its version
+		[]	-> dep_pkgid	-- No installed package; use 
+					-- the version-less one
 
 	is_exposed = exposed new_pkg
 	pkgid      = package new_pkg
@@ -766,7 +776,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 +794,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
@@ -900,7 +913,7 @@ dieOrForce force s
 -----------------------------------------
 --	Cut and pasted from ghc/compiler/SysTools
 
-#if defined(mingw32_TARGET_OS)
+#if defined(mingw32_HOST_OS)
 subst a b ls = map (\ x -> if x == a then b else x) ls
 unDosifyPath xs = subst '\\' '/' xs
 
@@ -925,3 +938,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_HOST_OS
+pathSeparator = '\\'
+#else
+pathSeparator = '/'
+#endif