[project @ 2005-01-28 12:55:17 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 ce1e0b5..1b5f8f7 100644 (file)
--- a/ghc/utils/ghc-pkg/Main.hs
+++ b/ghc/utils/ghc-pkg/Main.hs
@@ -28,9 +28,7 @@ import qualified Control.Exception as Exception
 
 import Prelude
 
-#if __GLASGOW_HASKELL__ < 603
-#include "config.h"
-#endif
+#include "../../includes/ghcconfig.h"
 
 #if __GLASGOW_HASKELL__ >= 504
 import System.Console.GetOpt
@@ -51,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
@@ -309,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
@@ -541,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.")
 
 
@@ -605,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"
@@ -626,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
@@ -768,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
       
@@ -786,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
@@ -902,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
 
@@ -964,7 +975,7 @@ isPathSeparator ch = ch == pathSeparator || ch == '/'
 -- separator is a slash (@\"\/\"@) on Unix and Macintosh, and a backslash
 -- (@\"\\\"@) on the Windows operating system.
 pathSeparator :: Char
-#ifdef mingw32_TARGET_OS
+#ifdef mingw32_HOST_OS
 pathSeparator = '\\'
 #else
 pathSeparator = '/'