[project @ 2005-02-11 10:35:06 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 d6da914..c0bc72b 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
@@ -342,12 +340,6 @@ parsePackageInfo str defines force =
     ParseOk ok -> return ok
     ParseFailed err -> die (showError err)
 
--- Used for converting versionless package names to new
--- PackageIdentifiers.  "Version [] []" is special: it means "no
--- version" or "any version"
-pkgNameToId :: String -> PackageIdentifier
-pkgNameToId name = PackageIdentifier name (Version [] [])
-
 -- -----------------------------------------------------------------------------
 -- Exposing, Hiding, Unregistering are all similar
 
@@ -507,6 +499,7 @@ validatePackageConfig :: InstalledPackageInfo
                      -> Bool   -- force
                      -> IO ()
 validatePackageConfig pkg db_stack auto_ghci_libs update force = do
+  checkPackageId pkg
   checkDuplicates db_stack pkg update
   mapM_        (checkDep db_stack force) (depends pkg)
   mapM_        (checkDir force) (importDirs pkg)
@@ -517,6 +510,17 @@ validatePackageConfig pkg db_stack auto_ghci_libs update force = do
   --   extra_libraries :: [String],
   --   c_includes      :: [String],
 
+-- When the package name and version are put together, sometimes we can
+-- end up with a package id that cannot be parsed.  This will lead to 
+-- difficulties when the user wants to refer to the package later, so
+-- we check that the package id can be parsed properly here.
+checkPackageId :: InstalledPackageInfo -> IO ()
+checkPackageId ipi =
+  let str = showPackageId (package ipi) in
+  case [ x | (x,ys) <- readP_to_S parsePackageId str, all isSpace ys ] of
+    [_] -> return ()
+    []  -> die ("invalid package identifier: " ++ str)
+    _   -> die ("ambiguous package identifier: " ++ str)
 
 checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> IO ()
 checkDuplicates db_stack pkg update = do
@@ -605,7 +609,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,19 +630,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)
---        = pkgid
+       resolveDep dep_pkgid
+          | realVersion dep_pkgid  = dep_pkgid
+          | otherwise              = lookupDep dep_pkgid
 
-       lookupDep name
-          = my_head "dep" [ pid | p <- concat (map snd db_stack), 
+       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
@@ -780,12 +793,19 @@ 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 (pkgNameToId p) db_stack
-    [ OF_Show p ]
-       | null fields -> describePackage db_stack (pkgNameToId p)
-       | otherwise   -> mapM_ (describeField db_stack (pkgNameToId p)) fields
-    _            -> do prog <- getProgramName
-                      die (usageInfo (usageHeader prog) flags)
+    [ OF_Remove pkgid_str ]  -> do
+       pkgid <- readPkgId pkgid_str
+       unregisterPackage pkgid db_stack
+    [ OF_Show pkgid_str ]
+       | null fields -> do
+               pkgid <- readPkgId pkgid_str
+               describePackage db_stack pkgid
+       | otherwise   -> do
+               pkgid <- readPkgId pkgid_str
+               mapM_ (describeField db_stack pkgid) fields
+    _ -> do 
+       prog <- getProgramName
+       die (usageInfo (usageHeader prog) flags)
 
 my_head s [] = error s
 my_head s (x:xs) = x
@@ -906,7 +926,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
 
@@ -968,7 +988,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 = '/'