Teach ghc-pkg about $httptopdir

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

diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 29e2c8d..16c7b89 100644 (file)
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -99,6 +99,7 @@ data Flag
   | FlagAutoGHCiLibs
   | FlagDefinedName String String
   | FlagSimpleOutput
+  | FlagNamesOnly
   deriving Eq
 
 flags :: [OptDescr Flag]
@@ -124,7 +125,9 @@ flags = [
   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
   toDefined str =
@@ -491,7 +494,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 +556,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 +571,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
@@ -748,8 +756,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 +794,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 +1030,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)