remove --define-name from the --help usage message (#1596)

[ghc-hetmet.git] / utils / ghc-pkg / Main.hs

diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 29e2c8d..e0bae2f 100644 (file)
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -62,7 +62,7 @@ main :: IO ()
 main = do
   args <- getArgs
 
-  case getOpt Permute flags args of
+  case getOpt Permute (flags ++ deprecFlags) args of
         (cli,_,[]) | FlagHelp `elem` cli -> do
            prog <- getProgramName
            bye (usageInfo (usageHeader prog) flags)
@@ -99,6 +99,7 @@ data Flag
   | FlagAutoGHCiLibs
   | FlagDefinedName String String
   | FlagSimpleOutput
+  | FlagNamesOnly
   deriving Eq
 
 flags :: [OptDescr Flag]
@@ -119,14 +120,20 @@ flags = [
         "automatically build libs for GHCi (with register)",
   Option ['?'] ["help"] (NoArg FlagHelp)
         "display this help and exit",
-  Option ['D'] ["define-name"] (ReqArg toDefined "NAME=VALUE")
-          "define NAME as VALUE",
   Option ['V'] ["version"] (NoArg FlagVersion)
         "output version information and exit",
   Option [] ["simple-output"] (NoArg FlagSimpleOutput)
-        "print output in easy-to-parse format for some commands"
+        "print output in easy-to-parse format for some commands",
+  Option [] ["names-only"] (NoArg FlagNamesOnly)
+        "only print package names, not versions; can only be used with list --simple-output"
   ]
- where
+
+deprecFlags :: [OptDescr Flag]
+deprecFlags = [
+  Option ['D'] ["define-name"] (ReqArg toDefined "NAME=VALUE")
+          "define NAME as VALUE"
+  ]
+  where
   toDefined str =
     case break (=='=') str of
       (nm,[])    -> FlagDefinedName nm []
@@ -404,7 +411,7 @@ registerPackage input defines flags auto_ghci_libs update force = do
   pkg0 <- parsePackageInfo expanded defines
   putStrLn "done."
 
-  let pkg = resolveDeps db_stack pkg0
+  pkg <- resolveDeps db_stack pkg0
   validatePackageConfig pkg db_stack auto_ghci_libs update force
   let new_details = filter not_this (snd db_to_operate_on) ++ [pkg]
       not_this p = package p /= package pkg
@@ -491,7 +498,9 @@ listPackages flags mPackageName = do
                    where doc = text (showPackageId (package p))
 
         show_simple db_stack = do
-          let pkgs = map showPackageId $ sortBy compPkgIdVer $
+          let showPkg = if FlagNamesOnly `elem` flags then pkgName
+                                                      else showPackageId
+              pkgs = map showPkg $ sortBy compPkgIdVer $
                           map package (concatMap snd db_stack)
           when (null pkgs) $ die "no matches"
           hPutStrLn stdout $ concat $ intersperse " " pkgs
@@ -551,7 +560,7 @@ describeField flags pkgid field = do
         mapM_ (putStrLn . fn) (mungePackagePaths top_dir ps)
 
 mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]
--- Replace the string "$topdir" at the beginning of a path
+-- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path
 -- with the current topdir (obtained from the -B option).
 mungePackagePaths top_dir ps = map munge_pkg ps
   where
@@ -566,8 +575,11 @@ mungePackagePaths top_dir ps = map munge_pkg ps
   munge_paths = map munge_path
 
   munge_path p
-          | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p'
-          | otherwise                               = p
+   | Just p' <- maybePrefixMatch "$topdir"     p =            top_dir ++ p'
+   | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p'
+   | otherwise                               = p
+
+  toHttpPath p = "file:///" ++ p
 
 maybePrefixMatch :: String -> String -> Maybe String
 maybePrefixMatch []    rest = Just rest
@@ -707,9 +719,17 @@ checkPackageId ipi =
     []  -> die ("invalid package identifier: " ++ str)
     _   -> die ("ambiguous package identifier: " ++ str)
 
-resolveDeps :: PackageDBStack -> InstalledPackageInfo -> InstalledPackageInfo
-resolveDeps db_stack p = updateDeps p
+-- ToDo: remove this (see #1837)
+resolveDeps :: PackageDBStack -> InstalledPackageInfo -> IO InstalledPackageInfo
+resolveDeps db_stack p  = do
+    when (not (null unversioned_deps)) $
+       hPutStr stderr ("WARNING: unversioned dependencies are deprecated, "++
+                       "and will NOT be accepted by GHC 6.10: " ++
+                       unwords (map showPackageId unversioned_deps) ++ "\n")
+    return (updateDeps p)
   where
+        unversioned_deps = filter (not.realVersion) (depends p)
+
         -- The input package spec is allowed to give a package dependency
         -- without a version number; e.g.
         --      depends: base
@@ -748,8 +768,9 @@ checkDuplicates db_stack pkg update = do
 
 checkDir :: Force -> String -> IO ()
 checkDir force d
- | "$topdir" `isPrefixOf` d = return ()
-        -- can't check this, because we don't know what $topdir is
+ | "$topdir"     `isPrefixOf` d = return ()
+ | "$httptopdir" `isPrefixOf` d = return ()
+        -- can't check these, because we don't know what $(http)topdir is
  | otherwise = do
    there <- doesDirectoryExist d
    when (not there)
@@ -785,7 +806,8 @@ checkHSLib dirs auto_ghci_libs force lib = do
 
 doesLibExistIn :: String -> String -> IO Bool
 doesLibExistIn lib d
- | "$topdir" `isPrefixOf` d = return True
+ | "$topdir"     `isPrefixOf` d = return True
+ | "$httptopdir" `isPrefixOf` d = return True
  | otherwise                = doesFileExist (d ++ '/':lib)
 
 checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO ()
@@ -1020,7 +1042,10 @@ dieForcible s = die (s ++ " (use --force to override)")
 -- Cut and pasted from ghc/compiler/SysTools
 
 #if defined(mingw32_HOST_OS)
+subst :: Char -> Char -> String -> String
 subst a b ls = map (\ x -> if x == a then b else x) ls
+
+unDosifyPath :: FilePath -> FilePath
 unDosifyPath xs = subst '\\' '/' xs
 
 getExecDir :: String -> IO (Maybe String)