X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=19be560ea0a1c271f0e8c678ec801b0fadf11346;hb=be18544c3e59cab7f76bf3d07fe6aa27cf157b02;hp=414ec37f4feab83e25d79487086f20a5dddea5a1;hpb=4bd1e966ffb4985f180e9728328ff7e3e7b37bb1;p=ghc-hetmet.git

diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 414ec37..19be560 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -18,11 +18,17 @@ module Main (main) where
 import Version	( version, targetOS, targetARCH )
 import Distribution.InstalledPackageInfo
 import Distribution.Compat.ReadP
-import Distribution.ParseUtils	( showError )
+import Distribution.ParseUtils
 import Distribution.Package
 import Distribution.Version
-import Compat.Directory 	( getAppUserDataDirectory, createDirectoryIfMissing )
-import Compat.RawSystem 	( rawSystem )
+
+#ifdef USING_COMPAT
+import Compat.Directory ( getAppUserDataDirectory, createDirectoryIfMissing )
+import Compat.RawSystem ( rawSystem )
+#else
+import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing )
+import System.Cmd       ( rawSystem )
+#endif
 
 import Prelude
 
@@ -429,7 +435,9 @@ parsePackageInfo
 parsePackageInfo str defines =
   case parseInstalledPackageInfo str of
     ParseOk _warns ok -> return ok
-    ParseFailed err -> die (showError err)
+    ParseFailed err -> case locatedErrorMsg err of
+                           (Nothing, s) -> die s
+                           (Just l, s) -> die (show l ++ ": " ++ s)
 
 -- -----------------------------------------------------------------------------
 -- Exposing, Hiding, Unregistering are all similar
@@ -556,7 +564,34 @@ describeField flags pkgid field = do
     Nothing -> die ("unknown field: " ++ field)
     Just fn -> do
 	ps <- findPackages db_stack pkgid 
-	mapM_ (putStrLn.fn) ps
+        let top_dir = getFilenameDir (fst (last db_stack))
+	mapM_ (putStrLn . fn) (mungePackagePaths top_dir ps)
+
+mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]
+-- Replace the string "$topdir" at the beginning of a path
+-- with the current topdir (obtained from the -B option).
+mungePackagePaths top_dir ps = map munge_pkg ps
+  where
+  munge_pkg p = p{ importDirs        = munge_paths (importDirs p),
+		   includeDirs       = munge_paths (includeDirs p),
+    		   libraryDirs       = munge_paths (libraryDirs p),
+		   frameworkDirs     = munge_paths (frameworkDirs p),
+        	   haddockInterfaces = munge_paths (haddockInterfaces p),
+        	   haddockHTMLs      = munge_paths (haddockHTMLs p)
+                 }
+
+  munge_paths = map munge_path
+
+  munge_path p 
+	  | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p'
+	  | otherwise				    = p
+
+maybePrefixMatch :: String -> String -> Maybe String
+maybePrefixMatch []    rest = Just rest
+maybePrefixMatch (_:_) []   = Nothing
+maybePrefixMatch (p:pat) (r:rest)
+  | p == r    = maybePrefixMatch pat rest
+  | otherwise = Nothing
 
 toField :: String -> Maybe (InstalledPackageInfo -> String)
 -- backwards compatibility: