Make package.conf files a bit more readable

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

diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 75a3397..4b37684 100644 (file)
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -18,28 +18,26 @@ 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
 
 #include "../../includes/ghcconfig.h"
 
-#if __GLASGOW_HASKELL__ >= 504
 import System.Console.GetOpt
 import Text.PrettyPrint
 import qualified Control.Exception as Exception
 import Data.Maybe
-#else
-import GetOpt
-import Pretty
-import qualified Exception
-import Maybe
-#endif
-
 import Data.Char       ( isSpace )
 import Monad
 import Directory
@@ -47,21 +45,12 @@ import System       ( getArgs, getProgName, getEnv,
                  exitWith, ExitCode(..)
                )
 import System.IO
-#if __GLASGOW_HASKELL__ >= 600
 import System.IO.Error (try)
-#else
-import System.IO (try)
-#endif
 import Data.List ( isPrefixOf, isSuffixOf, intersperse, sortBy )
 
 #ifdef mingw32_HOST_OS
 import Foreign
-
-#if __GLASGOW_HASKELL__ >= 504
 import Foreign.C.String
-#else
-import CString
-#endif
 #endif
 
 import IO ( isPermissionError, isDoesNotExistError )
@@ -429,7 +418,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
@@ -490,7 +481,7 @@ listPackages flags mPackageName = do
 
   where show_normal pkg_map (db_name,pkg_confs) =
          hPutStrLn stdout (render $
-               text db_name <> comma $$ nest 4 packages
+               text db_name <> colon $$ nest 4 packages
                )
           where packages = fsep (punctuate comma (map pp_pkg pkg_confs))
                 pp_pkg p
@@ -556,7 +547,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:
@@ -623,7 +641,9 @@ writeNewConfig filename packages = do
       if isPermissionError e
       then die (filename ++ ": you don't have permission to modify this file")
       else ioError e
-  hPutStrLn h (show packages)
+  let shown = concat $ intersperse ",\n " $ map show packages
+      fileContents = "[" ++ shown ++ "\n]"
+  hPutStrLn h fileContents
   hClose h
   hPutStrLn stdout "done."