Don't use stdcall on Win64: It isn't supported; ccall is used instead
[ghc.git] / utils / ghc-pkg / Main.hs
index 79404bc..83b5447 100644 (file)
@@ -1,4 +1,4 @@
-{-# OPTIONS -fglasgow-exts -cpp #-}
+{-# LANGUAGE PatternGuards, CPP, ForeignFunctionInterface #-}
 -----------------------------------------------------------------------------
 --
 -- (c) The University of Glasgow 2004-2009.
@@ -19,7 +19,8 @@ import Distribution.ParseUtils
 import Distribution.Package hiding (depends)
 import Distribution.Text
 import Distribution.Version
-import System.FilePath
+import System.FilePath as FilePath
+import qualified System.FilePath.Posix as FilePath.Posix
 import System.Cmd       ( rawSystem )
 import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing,
                           getModificationTime )
@@ -27,24 +28,19 @@ import Text.Printf
 
 import Prelude
 
-#include "../../includes/ghcconfig.h"
-
 import System.Console.GetOpt
-#if __GLASGOW_HASKELL__ >= 609
 import qualified Control.Exception as Exception
-#else
-import qualified Control.Exception.Extensible as Exception
-#endif
 import Data.Maybe
 
 import Data.Char ( isSpace, toLower )
 import Control.Monad
 import System.Directory ( doesDirectoryExist, getDirectoryContents,
-                          doesFileExist, renameFile, removeFile )
+                          doesFileExist, renameFile, removeFile,
+                          getCurrentDirectory )
 import System.Exit ( exitWith, ExitCode(..) )
 import System.Environment ( getArgs, getProgName, getEnv )
 import System.IO
-import System.IO.Error (try)
+import System.IO.Error
 import Data.List
 import Control.Concurrent
 
@@ -52,15 +48,10 @@ import qualified Data.ByteString.Lazy as B
 import qualified Data.Binary as Bin
 import qualified Data.Binary.Get as Bin
 
-#if __GLASGOW_HASKELL__ < 612
+#if defined(mingw32_HOST_OS)
+-- mingw32 needs these for getExecDir, GHC <6.12 needs them for openNewFile
 import Foreign
 import Foreign.C
-import System.Posix.Internals
-#if __GLASGOW_HASKELL__ >= 611
-import GHC.IO.Handle.FD (fdToHandle)
-#else
-import GHC.Handle (fdToHandle)
-#endif
 #endif
 
 #ifdef mingw32_HOST_OS
@@ -69,17 +60,25 @@ import GHC.ConsoleHandler
 import System.Posix hiding (fdToHandle)
 #endif
 
-import IO ( isPermissionError )
-
 #if defined(GLOB)
 import System.Process(runInteractiveCommand)
 import qualified System.Info(os)
 #endif
 
-#if !defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ >= 611 && !defined(BOOTSTRAPPING)
+#if !defined(mingw32_HOST_OS) && !defined(BOOTSTRAPPING)
 import System.Console.Terminfo as Terminfo
 #endif
 
+#ifdef mingw32_HOST_OS
+# if defined(i386_HOST_ARCH)
+#  define WINDOWS_CCONV stdcall
+# elif defined(x86_64_HOST_ARCH)
+#  define WINDOWS_CCONV ccall
+# else
+#  error Unknown mingw32 arch
+# endif
+#endif
+
 -- -----------------------------------------------------------------------------
 -- Entry point
 
@@ -114,6 +113,9 @@ data Flag
   | FlagForce
   | FlagForceFiles
   | FlagAutoGHCiLibs
+  | FlagExpandEnvVars
+  | FlagExpandPkgroot
+  | FlagNoExpandPkgroot
   | FlagSimpleOutput
   | FlagNamesOnly
   | FlagIgnoreCase
@@ -127,11 +129,11 @@ flags = [
         "use the current user's package database",
   Option [] ["global"] (NoArg FlagGlobal)
         "use the global package database",
-  Option ['f'] ["package-conf"] (ReqArg FlagConfig "FILE")
+  Option ['f'] ["package-db"] (ReqArg FlagConfig "FILE")
         "use the specified package config file",
-  Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE")
+  Option [] ["global-package-db"] (ReqArg FlagGlobalConfig "FILE")
         "location of the global package config",
-  Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb)
+  Option [] ["no-user-package-db"] (NoArg FlagNoUserDb)
         "never read the user package database",
   Option [] ["force"] (NoArg FlagForce)
          "ignore missing dependencies, directories, and libraries",
@@ -139,6 +141,12 @@ flags = [
          "ignore missing directories and libraries only",
   Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
         "automatically build libs for GHCi (with register)",
+  Option [] ["expand-env-vars"] (NoArg FlagExpandEnvVars)
+        "expand environment variables (${name}-style) in input package descriptions",
+  Option [] ["expand-pkgroot"] (NoArg FlagExpandPkgroot)
+        "expand ${pkgroot}-relative paths to absolute in output package descriptions",
+  Option [] ["no-expand-pkgroot"] (NoArg FlagNoExpandPkgroot)
+        "preserve ${pkgroot}-relative paths in output package descriptions",
   Option ['?'] ["help"] (NoArg FlagHelp)
         "display this help and exit",
   Option ['V'] ["version"] (NoArg FlagVersion)
@@ -179,8 +187,8 @@ usageHeader prog = substProg prog $
   "  $p init {path}\n" ++
   "    Create and initialise a package database at the location {path}.\n" ++
   "    Packages can be registered in the new database using the register\n" ++
-  "    command with --package-conf={path}.  To use the new database with GHC,\n" ++
-  "    use GHC's -package-conf flag.\n" ++
+  "    command with --package-db={path}.  To use the new database with GHC,\n" ++
+  "    use GHC's -package-db flag.\n" ++
   "\n" ++
   "  $p register {filename | -}\n" ++
   "    Register the package using the specified installed package\n" ++
@@ -200,6 +208,12 @@ usageHeader prog = substProg prog $
   "  $p hide {pkg-id}\n" ++
   "    Hide the specified package.\n" ++
   "\n" ++
+  "  $p trust {pkg-id}\n" ++
+  "    Trust the specified package.\n" ++
+  "\n" ++
+  "  $p distrust {pkg-id}\n" ++
+  "    Distrust the specified package.\n" ++
+  "\n" ++
   "  $p list [pkg]\n" ++
   "    List registered packages in the global database, and also the\n" ++
   "    user database if --user is given. If a package name is given\n" ++
@@ -243,7 +257,7 @@ usageHeader prog = substProg prog $
   "    Regenerate the package database cache.  This command should only be\n" ++
   "    necessary if you added a package to the database by dropping a file\n" ++
   "    into the database directory manually.  By default, the global DB\n" ++
-  "    is recached; to recache a different DB use --user or --package-conf\n" ++
+  "    is recached; to recache a different DB use --user or --package-db\n" ++
   "    as appropriate.\n" ++
   "\n" ++
   " Substring matching is supported for {module} in find-module and\n" ++
@@ -253,13 +267,13 @@ usageHeader prog = substProg prog $
   "  When asked to modify a database (register, unregister, update,\n"++
   "  hide, expose, and also check), ghc-pkg modifies the global database by\n"++
   "  default.  Specifying --user causes it to act on the user database,\n"++
-  "  or --package-conf can be used to act on another database\n"++
+  "  or --package-db can be used to act on another database\n"++
   "  entirely. When multiple of these options are given, the rightmost\n"++
   "  one is used as the database to act upon.\n"++
   "\n"++
   "  Commands that query the package database (list, tree, latest, describe,\n"++
   "  field) operate on the list of databases specified by the flags\n"++
-  "  --user, --global, and --package-conf.  If none of these flags are\n"++
+  "  --user, --global, and --package-db.  If none of these flags are\n"++
   "  given, the default is --global --user.\n"++
   "\n" ++
   " The following optional flags are also accepted:\n"
@@ -287,6 +301,12 @@ runit verbosity cli nonopts = do
           | FlagForceFiles `elem` cli   = ForceFiles
           | otherwise                   = NoForce
         auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
+        expand_env_vars= FlagExpandEnvVars `elem` cli
+        mexpand_pkgroot= foldl' accumExpandPkgroot Nothing cli
+          where accumExpandPkgroot _ FlagExpandPkgroot   = Just True
+                accumExpandPkgroot _ FlagNoExpandPkgroot = Just False
+                accumExpandPkgroot x _                   = x
+                
         splitFields fields = unfoldr splitComma (',':fields)
           where splitComma "" = Nothing
                 splitComma fs = Just $ break (==',') (tail fs)
@@ -326,9 +346,11 @@ runit verbosity cli nonopts = do
     ["init", filename] ->
         initPackageDB filename verbosity cli
     ["register", filename] ->
-        registerPackage filename verbosity cli auto_ghci_libs False force
+        registerPackage filename verbosity cli
+                        auto_ghci_libs expand_env_vars False force
     ["update", filename] ->
-        registerPackage filename verbosity cli auto_ghci_libs True force
+        registerPackage filename verbosity cli
+                        auto_ghci_libs expand_env_vars True force
     ["unregister", pkgid_str] -> do
         pkgid <- readGlobPkgId pkgid_str
         unregisterPackage pkgid verbosity cli force
@@ -338,6 +360,12 @@ runit verbosity cli nonopts = do
     ["hide",   pkgid_str] -> do
         pkgid <- readGlobPkgId pkgid_str
         hidePackage pkgid verbosity cli force
+    ["trust",    pkgid_str] -> do
+        pkgid <- readGlobPkgId pkgid_str
+        trustPackage pkgid verbosity cli force
+    ["distrust", pkgid_str] -> do
+        pkgid <- readGlobPkgId pkgid_str
+        distrustPackage pkgid verbosity cli force
     ["list"] -> do
         listPackages verbosity cli Nothing Nothing
     ["list", pkgid_str] ->
@@ -353,23 +381,24 @@ runit verbosity cli nonopts = do
     ["latest", pkgid_str] -> do
         pkgid <- readGlobPkgId pkgid_str
         latestPackage verbosity cli pkgid
-    ["describe", pkgid_str] ->
-        case substringCheck pkgid_str of
-          Nothing -> do pkgid <- readGlobPkgId pkgid_str
-                        describePackage verbosity cli (Id pkgid)
-          Just m -> describePackage verbosity cli (Substring pkgid_str m)
-    ["field", pkgid_str, fields] ->
-        case substringCheck pkgid_str of
-          Nothing -> do pkgid <- readGlobPkgId pkgid_str
-                        describeField verbosity cli (Id pkgid) 
-                                      (splitFields fields)
-          Just m -> describeField verbosity cli (Substring pkgid_str m)
-                                      (splitFields fields)
+    ["describe", pkgid_str] -> do
+        pkgarg <- case substringCheck pkgid_str of
+          Nothing -> liftM Id (readGlobPkgId pkgid_str)
+          Just m  -> return (Substring pkgid_str m)
+        describePackage verbosity cli pkgarg (fromMaybe False mexpand_pkgroot)
+        
+    ["field", pkgid_str, fields] -> do
+        pkgarg <- case substringCheck pkgid_str of
+          Nothing -> liftM Id (readGlobPkgId pkgid_str)
+          Just m  -> return (Substring pkgid_str m)
+        describeField verbosity cli pkgarg
+                      (splitFields fields) (fromMaybe True mexpand_pkgroot)
+
     ["check"] -> do
         checkConsistency verbosity cli
 
     ["dump"] -> do
-        dumpPackages verbosity cli
+        dumpPackages verbosity cli (fromMaybe False mexpand_pkgroot)
 
     ["recache"] -> do
         recache verbosity cli
@@ -406,7 +435,7 @@ globVersion = Version{ versionBranch=[], versionTags=["*"] }
 -- Package databases
 
 -- Some commands operate on a single database:
---      register, unregister, expose, hide
+--      register, unregister, expose, hide, trust, distrust
 -- however these commands also check the union of the available databases
 -- in order to check consistency.  For example, register will check that
 -- dependencies exist before registering a package.
@@ -415,8 +444,16 @@ globVersion = Version{ versionBranch=[], versionTags=["*"] }
 --      list, describe, field
 
 data PackageDB 
-  = PackageDB { location :: FilePath,
-                packages :: [InstalledPackageInfo] }
+  = PackageDB {
+      location, locationAbsolute :: !FilePath,
+      -- We need both possibly-relative and definately-absolute package
+      -- db locations. This is because the relative location is used as
+      -- an identifier for the db, so it is important we do not modify it.
+      -- On the other hand we need the absolute path in a few places
+      -- particularly in relation to the ${pkgroot} stuff.
+      
+      packages :: [InstalledPackageInfo]
+    }
 
 type PackageDBStack = [PackageDB]
         -- A stack of package databases.  Convention: head is the topmost
@@ -428,6 +465,7 @@ allPackagesInStack = concatMap packages
 getPkgDatabases :: Verbosity
                 -> Bool    -- we are modifying, not reading
                 -> Bool    -- read caches, if available
+                -> Bool    -- expand vars, like ${pkgroot} and $topdir
                 -> [Flag]
                 -> IO (PackageDBStack, 
                           -- the real package DB stack: [global,user] ++ 
@@ -440,12 +478,12 @@ getPkgDatabases :: Verbosity
                           -- is used as the list of package DBs for
                           -- commands that just read the DB, such as 'list'.
 
-getPkgDatabases verbosity modify use_cache my_flags = do
+getPkgDatabases verbosity modify use_cache expand_vars my_flags = do
   -- first we determine the location of the global package config.  On Windows,
   -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
-  -- location is passed to the binary using the --global-config flag by the
+  -- location is passed to the binary using the --global-package-db flag by the
   -- wrapper script.
-  let err_msg = "missing --global-conf option, location of global package.conf unknown\n"
+  let err_msg = "missing --global-package-db option, location of global package database unknown\n"
   global_conf <-
      case [ f | FlagGlobalConfig f <- my_flags ] of
         [] -> do mb_dir <- getLibDir
@@ -458,11 +496,17 @@ getPkgDatabases verbosity modify use_cache my_flags = do
                        Just path -> return path
         fs -> return (last fs)
 
+  -- The value of the $topdir variable used in some package descriptions
+  -- Note that the way we calculate this is slightly different to how it
+  -- is done in ghc itself. We rely on the convention that the global
+  -- package db lives in ghc's libdir.
+  top_dir <- absolutePath (takeDirectory global_conf)
+
   let no_user_db = FlagNoUserDb `elem` my_flags
 
   -- get the location of the user package database, and create it if necessary
   -- getAppUserDataDirectory can fail (e.g. if $HOME isn't set)
-  e_appdir <- try $ getAppUserDataDirectory "ghc"
+  e_appdir <- tryIO $ getAppUserDataDirectory "ghc"
 
   mb_user_conf <-
      if no_user_db then return Nothing else
@@ -483,7 +527,7 @@ getPkgDatabases verbosity modify use_cache my_flags = do
           modify || user_exists = [user_conf, global_conf]
         | otherwise             = [global_conf]
 
-  e_pkg_path <- try (System.Environment.getEnv "GHC_PACKAGE_PATH")
+  e_pkg_path <- tryIO (System.Environment.getEnv "GHC_PACKAGE_PATH")
   let env_stack =
         case e_pkg_path of
                 Left  _ -> sys_databases
@@ -526,7 +570,11 @@ getPkgDatabases verbosity modify use_cache my_flags = do
         | null db_flags = Just virt_global_conf
         | otherwise     = Just (last db_flags)
 
-  db_stack <- mapM (readParseDatabase verbosity mb_user_conf use_cache) final_stack
+  db_stack  <- sequence
+    [ do db <- readParseDatabase verbosity mb_user_conf use_cache db_path
+         if expand_vars then return (mungePackageDBPaths top_dir db)
+                        else return db
+    | db_path <- final_stack ]
 
   let flag_db_stack = [ db | db_name <- flag_db_names,
                         db <- db_stack, location db == db_name ]
@@ -552,42 +600,50 @@ readParseDatabase :: Verbosity
 readParseDatabase verbosity mb_user_conf use_cache path
   -- the user database (only) is allowed to be non-existent
   | Just (user_conf,False) <- mb_user_conf, path == user_conf
-  = return PackageDB { location = path, packages = [] }
+  = mkPackageDB []
   | otherwise
-  = do e <- try $ getDirectoryContents path
+  = do e <- tryIO $ getDirectoryContents path
        case e of
          Left _   -> do
               pkgs <- parseMultiPackageConf verbosity path
-              return PackageDB{ location = path, packages = pkgs }              
+              mkPackageDB pkgs
          Right fs
            | not use_cache -> ignore_cache
            | otherwise -> do
               let cache = path </> cachefilename
               tdir     <- getModificationTime path
-              e_tcache <- try $ getModificationTime cache
+              e_tcache <- tryIO $ getModificationTime cache
               case e_tcache of
                 Left ex -> do
                      when (verbosity > Normal) $
-                        putStrLn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex)
+                        warn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex)
                      ignore_cache
                 Right tcache
                   | tcache >= tdir -> do
                      when (verbosity > Normal) $
-                        putStrLn ("using cache: " ++ cache)
+                        infoLn ("using cache: " ++ cache)
                      pkgs <- myReadBinPackageDB cache
                      let pkgs' = map convertPackageInfoIn pkgs
-                     return PackageDB { location = path, packages = pkgs' }
+                     mkPackageDB pkgs'
                   | otherwise -> do
                      when (verbosity >= Normal) $ do
-                        putStrLn ("WARNING: cache is out of date: " ++ cache)
-                        putStrLn "  use 'ghc-pkg recache' to fix."
+                        warn ("WARNING: cache is out of date: " ++ cache)
+                        warn "  use 'ghc-pkg recache' to fix."
                      ignore_cache
             where
                  ignore_cache = do
                      let confs = filter (".conf" `isSuffixOf`) fs
                      pkgs <- mapM (parseSingletonPackageConf verbosity) $
                                    map (path </>) confs
-                     return PackageDB { location = path, packages = pkgs }
+                     mkPackageDB pkgs
+  where
+    mkPackageDB pkgs = do
+      path_abs <- absolutePath path
+      return PackageDB {
+        location = path,
+        locationAbsolute = path_abs,
+        packages = pkgs
+      }
 
 -- read the package.cache file strictly, to work around a problem with
 -- bytestring 0.9.0.x (fixed in 0.9.1.x) where the file wasn't closed
@@ -603,7 +659,7 @@ myReadBinPackageDB filepath = do
 
 parseMultiPackageConf :: Verbosity -> FilePath -> IO [InstalledPackageInfo]
 parseMultiPackageConf verbosity file = do
-  when (verbosity > Normal) $ putStrLn ("reading package database: " ++ file)
+  when (verbosity > Normal) $ infoLn ("reading package database: " ++ file)
   str <- readUTF8File file
   let pkgs = map convertPackageInfoIn $ read str
   Exception.evaluate pkgs
@@ -612,12 +668,73 @@ parseMultiPackageConf verbosity file = do
   
 parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
 parseSingletonPackageConf verbosity file = do
-  when (verbosity > Normal) $ putStrLn ("reading package config: " ++ file)
-  readUTF8File file >>= parsePackageInfo
+  when (verbosity > Normal) $ infoLn ("reading package config: " ++ file)
+  readUTF8File file >>= fmap fst . parsePackageInfo
 
 cachefilename :: FilePath
 cachefilename = "package.cache"
 
+mungePackageDBPaths :: FilePath -> PackageDB -> PackageDB
+mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } =
+    db { packages = map (mungePackagePaths top_dir pkgroot) pkgs }
+  where
+    pkgroot = takeDirectory (locationAbsolute db)    
+    -- It so happens that for both styles of package db ("package.conf"
+    -- files and "package.conf.d" dirs) the pkgroot is the parent directory
+    -- ${pkgroot}/package.conf  or  ${pkgroot}/package.conf.d/
+
+-- TODO: This code is duplicated in compiler/main/Packages.lhs
+mungePackagePaths :: FilePath -> FilePath
+                  -> InstalledPackageInfo -> InstalledPackageInfo
+-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
+-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
+-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
+-- The "pkgroot" is the directory containing the package database.
+--
+-- Also perform a similar substitution for the older GHC-specific
+-- "$topdir" variable. The "topdir" is the location of the ghc
+-- installation (obtained from the -B option).
+mungePackagePaths top_dir pkgroot pkg =
+    pkg {
+      importDirs  = munge_paths (importDirs pkg),
+      includeDirs = munge_paths (includeDirs pkg),
+      libraryDirs = munge_paths (libraryDirs pkg),
+      frameworkDirs = munge_paths (frameworkDirs pkg),
+      haddockInterfaces = munge_paths (haddockInterfaces pkg),
+                     -- haddock-html is allowed to be either a URL or a file
+      haddockHTMLs = munge_paths (munge_urls (haddockHTMLs pkg))
+    }
+  where
+    munge_paths = map munge_path
+    munge_urls  = map munge_url
+
+    munge_path p
+      | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'
+      | Just p' <- stripVarPrefix "$topdir"    p = top_dir ++ p'
+      | otherwise                                = p
+
+    munge_url p
+      | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'
+      | Just p' <- stripVarPrefix "$httptopdir"   p = toUrlPath top_dir p'
+      | otherwise                                   = p
+
+    toUrlPath r p = "file:///"
+                 -- URLs always use posix style '/' separators:
+                 ++ FilePath.Posix.joinPath
+                        (r : -- We need to drop a leading "/" or "\\"
+                             -- if there is one:
+                             dropWhile (all isPathSeparator)
+                                       (FilePath.splitDirectories p))
+
+    -- We could drop the separator here, and then use </> above. However,
+    -- by leaving it in and using ++ we keep the same path separator
+    -- rather than letting FilePath change it to use \ as the separator
+    stripVarPrefix var path = case stripPrefix var path of
+                              Just [] -> Just []
+                              Just cs@(c : _) | isPathSeparator c -> Just cs
+                              _ -> Nothing
+
+
 -- -----------------------------------------------------------------------------
 -- Creating a new package DB
 
@@ -628,7 +745,11 @@ initPackageDB filename verbosity _flags = do
   when b1 eexist
   b2 <- doesDirectoryExist filename
   when b2 eexist
-  changeDB verbosity [] PackageDB{ location = filename, packages = [] }
+  filename_abs <- absolutePath filename
+  changeDB verbosity [] PackageDB {
+                          location = filename, locationAbsolute = filename_abs,
+                          packages = []
+                        }
 
 -- -----------------------------------------------------------------------------
 -- Registering
@@ -637,42 +758,54 @@ registerPackage :: FilePath
                 -> Verbosity
                 -> [Flag]
                 -> Bool              -- auto_ghci_libs
+                -> Bool              -- expand_env_vars
                 -> Bool              -- update
                 -> Force
                 -> IO ()
-registerPackage input verbosity my_flags auto_ghci_libs update force = do
+registerPackage input verbosity my_flags auto_ghci_libs expand_env_vars update force = do
   (db_stack, Just to_modify, _flag_dbs) <- 
-      getPkgDatabases verbosity True True my_flags
+      getPkgDatabases verbosity True True False{-expand vars-} my_flags
 
   let
         db_to_operate_on = my_head "register" $
                            filter ((== to_modify).location) db_stack
   --
+  when (auto_ghci_libs && verbosity >= Silent) $
+    warn "Warning: --auto-ghci-libs is deprecated and will be removed in GHC 7.4"
+  --
   s <-
     case input of
       "-" -> do
         when (verbosity >= Normal) $
-            putStr "Reading package info from stdin ... "
-#if __GLASGOW_HASKELL__ >= 612
+            info "Reading package info from stdin ... "
         -- fix the encoding to UTF-8, since this is an interchange format
         hSetEncoding stdin utf8
-#endif
         getContents
       f   -> do
         when (verbosity >= Normal) $
-            putStr ("Reading package info from " ++ show f ++ " ... ")
+            info ("Reading package info from " ++ show f ++ " ... ")
         readUTF8File f
 
-  expanded <- expandEnvVars s force
+  expanded <- if expand_env_vars then expandEnvVars s force
+                                 else return s
 
-  pkg <- parsePackageInfo expanded
+  (pkg, ws) <- parsePackageInfo expanded
   when (verbosity >= Normal) $
-      putStrLn "done."
+      infoLn "done."
+
+  -- report any warnings from the parse phase
+  _ <- reportValidateErrors [] ws
+         (display (sourcePackageId pkg) ++ ": Warning: ") Nothing
+
+  -- validate the expanded pkg, but register the unexpanded
+  pkgroot <- absolutePath (takeDirectory to_modify)
+  let top_dir = takeDirectory (location (last db_stack))
+      pkg_expanded = mungePackagePaths top_dir pkgroot pkg
 
   let truncated_stack = dropWhile ((/= to_modify).location) db_stack
   -- truncate the stack for validation, because we don't allow
   -- packages lower in the stack to refer to those higher up.
-  validatePackageConfig pkg truncated_stack auto_ghci_libs update force
+  validatePackageConfig pkg_expanded verbosity truncated_stack auto_ghci_libs update force
   let 
      removes = [ RemovePackage p
                | p <- packages db_to_operate_on,
@@ -682,10 +815,13 @@ registerPackage input verbosity my_flags auto_ghci_libs update force = do
 
 parsePackageInfo
         :: String
-        -> IO InstalledPackageInfo
+        -> IO (InstalledPackageInfo, [ValidateWarning])
 parsePackageInfo str =
   case parseInstalledPackageInfo str of
-    ParseOk _warns ok -> return ok
+    ParseOk warnings ok -> return (ok, ws)
+      where
+        ws = [ msg | PWarning msg <- warnings
+                   , not ("Unrecognized field pkgroot" `isPrefixOf` msg) ]
     ParseFailed err -> case locatedErrorMsg err of
                            (Nothing, s) -> die s
                            (Just l, s) -> die (show l ++ ": " ++ s)
@@ -724,11 +860,11 @@ changeDBDir verbosity cmds db = do
  where
   do_cmd (RemovePackage p) = do
     let file = location db </> display (installedPackageId p) <.> "conf"
-    when (verbosity > Normal) $ putStrLn ("removing " ++ file)
-    removeFile file
+    when (verbosity > Normal) $ infoLn ("removing " ++ file)
+    removeFileSafe file
   do_cmd (AddPackage p) = do
     let file = location db </> display (installedPackageId p) <.> "conf"
-    when (verbosity > Normal) $ putStrLn ("writing " ++ file)
+    when (verbosity > Normal) $ infoLn ("writing " ++ file)
     writeFileUtf8Atomic file (showInstalledPackageInfo p)
   do_cmd (ModifyPackage p) = 
     do_cmd (AddPackage p)
@@ -737,15 +873,15 @@ updateDBCache :: Verbosity -> PackageDB -> IO ()
 updateDBCache verbosity db = do
   let filename = location db </> cachefilename
   when (verbosity > Normal) $
-      putStrLn ("writing cache " ++ filename)
+      infoLn ("writing cache " ++ filename)
   writeBinaryFileAtomic filename (map convertPackageInfoOut (packages db))
-    `catch` \e ->
+    `catchIO` \e ->
       if isPermissionError e
       then die (filename ++ ": you don't have permission to modify this file")
       else ioError e
 
 -- -----------------------------------------------------------------------------
--- Exposing, Hiding, Unregistering are all similar
+-- Exposing, Hiding, Trusting, Distrusting, Unregistering are all similar
 
 exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
 exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True})
@@ -753,6 +889,12 @@ exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True})
 hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
 hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False})
 
+trustPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
+trustPackage = modifyPackage (\p -> ModifyPackage p{trusted=True})
+
+distrustPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
+distrustPackage = modifyPackage (\p -> ModifyPackage p{trusted=False})
+
 unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
 unregisterPackage = modifyPackage RemovePackage
 
@@ -765,7 +907,7 @@ modifyPackage
   -> IO ()
 modifyPackage fn pkgid verbosity my_flags force = do
   (db_stack, Just _to_modify, _flag_dbs) <- 
-      getPkgDatabases verbosity True{-modify-} True{-use cache-} my_flags
+      getPkgDatabases verbosity True{-modify-} True{-use cache-} False{-expand vars-} my_flags
 
   (db, ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid)
   let 
@@ -793,7 +935,7 @@ modifyPackage fn pkgid verbosity my_flags force = do
 recache :: Verbosity -> [Flag] -> IO ()
 recache verbosity my_flags = do
   (db_stack, Just to_modify, _flag_dbs) <- 
-     getPkgDatabases verbosity True{-modify-} False{-no cache-} my_flags
+     getPkgDatabases verbosity True{-modify-} False{-no cache-} False{-expand vars-} my_flags
   let
         db_to_operate_on = my_head "recache" $
                            filter ((== to_modify).location) db_stack
@@ -809,7 +951,7 @@ listPackages ::  Verbosity -> [Flag] -> Maybe PackageArg
 listPackages verbosity my_flags mPackageName mModuleName = do
   let simple_output = FlagSimpleOutput `elem` my_flags
   (db_stack, _, flag_db_stack) <- 
-     getPkgDatabases verbosity False True{-use cache-} my_flags
+     getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags
 
   let db_stack_filtered -- if a package is given, filter out all other packages
         | Just this <- mPackageName =
@@ -856,11 +998,11 @@ listPackages verbosity my_flags mPackageName mModuleName = do
 
   when (not (null broken) && not simple_output && verbosity /= Silent) $ do
      prog <- getProgramName
-     putStrLn ("WARNING: there are broken packages.  Run '" ++ prog ++ " check' for more details.")
+     warn ("WARNING: there are broken packages.  Run '" ++ prog ++ " check' for more details.")
 
   if simple_output then show_simple stack else do
 
-#if defined(mingw32_HOST_OS) || __GLASGOW_HASKELL__ < 611 || defined(BOOTSTRAPPING)
+#if defined(mingw32_HOST_OS) || defined(BOOTSTRAPPING)
   mapM_ show_normal stack
 #else
   let
@@ -902,7 +1044,7 @@ simplePackageList my_flags pkgs = do
 showPackageDot :: Verbosity -> [Flag] -> IO ()
 showPackageDot verbosity myflags = do
   (_, _, flag_db_stack) <- 
-      getPkgDatabases verbosity False True{-use cache-} myflags
+      getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} myflags
 
   let all_pkgs = allPackagesInStack flag_db_stack
       ipix  = PackageIndex.fromList all_pkgs
@@ -924,7 +1066,7 @@ showPackageDot verbosity myflags = do
 latestPackage ::  Verbosity -> [Flag] -> PackageIdentifier -> IO ()
 latestPackage verbosity my_flags pkgid = do
   (_, _, flag_db_stack) <- 
-     getPkgDatabases verbosity False True{-use cache-} my_flags
+     getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags
 
   ps <- findPackages flag_db_stack (Id pkgid)
   show_pkg (sortBy compPkgIdVer (map sourcePackageId ps))
@@ -935,26 +1077,33 @@ latestPackage verbosity my_flags pkgid = do
 -- -----------------------------------------------------------------------------
 -- Describe
 
-describePackage :: Verbosity -> [Flag] -> PackageArg -> IO ()
-describePackage verbosity my_flags pkgarg = do
+describePackage :: Verbosity -> [Flag] -> PackageArg -> Bool -> IO ()
+describePackage verbosity my_flags pkgarg expand_pkgroot = do
   (_, _, flag_db_stack) <- 
-      getPkgDatabases verbosity False True{-use cache-} my_flags
-  ps <- findPackages flag_db_stack pkgarg
-  doDump ps
+      getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
+  dbs <- findPackagesByDB flag_db_stack pkgarg
+  doDump expand_pkgroot [ (pkg, locationAbsolute db)
+                        | (db, pkgs) <- dbs, pkg <- pkgs ]
 
-dumpPackages :: Verbosity -> [Flag] -> IO ()
-dumpPackages verbosity my_flags = do
+dumpPackages :: Verbosity -> [Flag] -> Bool -> IO ()
+dumpPackages verbosity my_flags expand_pkgroot = do
   (_, _, flag_db_stack) <- 
-     getPkgDatabases verbosity False True{-use cache-} my_flags
-  doDump (allPackagesInStack flag_db_stack)
+     getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
+  doDump expand_pkgroot [ (pkg, locationAbsolute db)
+                        | db <- flag_db_stack, pkg <- packages db ]
 
-doDump :: [InstalledPackageInfo] -> IO ()
-doDump pkgs = do
-#if __GLASGOW_HASKELL__ >= 612
+doDump :: Bool -> [(InstalledPackageInfo, FilePath)] -> IO ()
+doDump expand_pkgroot pkgs = do
   -- fix the encoding to UTF-8, since this is an interchange format
   hSetEncoding stdout utf8
-#endif
-  mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo $ pkgs
+  putStrLn $
+    intercalate "---\n"
+    [ if expand_pkgroot
+        then showInstalledPackageInfo pkg
+        else showInstalledPackageInfo pkg ++ pkgrootField
+    | (pkg, pkgloc) <- pkgs
+    , let pkgroot      = takeDirectory pkgloc
+          pkgrootField = "pkgroot: " ++ show pkgroot ++ "\n" ]
 
 -- PackageId is can have globVersion for the version
 findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
@@ -993,49 +1142,19 @@ compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
 -- -----------------------------------------------------------------------------
 -- Field
 
-describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> IO ()
-describeField verbosity my_flags pkgarg fields = do
+describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> Bool -> IO ()
+describeField verbosity my_flags pkgarg fields expand_pkgroot = do
   (_, _, flag_db_stack) <- 
-      getPkgDatabases verbosity False True{-use cache-} my_flags
+      getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
   fns <- toFields fields
   ps <- findPackages flag_db_stack pkgarg
-  let top_dir = takeDirectory (location (last flag_db_stack))
-  mapM_ (selectFields fns) (mungePackagePaths top_dir ps)
+  mapM_ (selectFields fns) ps
   where toFields [] = return []
         toFields (f:fs) = case toField f of
             Nothing -> die ("unknown field: " ++ f)
             Just fn -> do fns <- toFields fs
                           return (fn:fns)
-        selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns
-
-mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]
--- 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
-  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'
-   | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p'
-   | otherwise                               = p
-
-  toHttpPath p = "file:///" ++ p
-
-maybePrefixMatch :: String -> String -> Maybe String
-maybePrefixMatch []    rest = Just rest
-maybePrefixMatch (_:_) []   = Nothing
-maybePrefixMatch (p:pat) (r:rest)
-  | p == r    = maybePrefixMatch pat rest
-  | otherwise = Nothing
+        selectFields fns pinfo = mapM_ (\fn->putStrLn (fn pinfo)) fns
 
 toField :: String -> Maybe (InstalledPackageInfo -> String)
 -- backwards compatibility:
@@ -1062,7 +1181,8 @@ strList = show
 
 checkConsistency :: Verbosity -> [Flag] -> IO ()
 checkConsistency verbosity my_flags = do
-  (db_stack, _, _) <- getPkgDatabases verbosity True True{-use cache-} my_flags
+  (db_stack, _, _) <- 
+         getPkgDatabases verbosity True True{-use cache-} True{-expand vars-} my_flags
          -- check behaves like modify for the purposes of deciding which
          -- databases to use, because ordering is important.
 
@@ -1071,13 +1191,16 @@ checkConsistency verbosity my_flags = do
   let pkgs = allPackagesInStack db_stack
 
       checkPackage p = do
-         (_,es) <- runValidate $ checkPackageConfig p db_stack False True
+         (_,es,ws) <- runValidate $ checkPackageConfig p verbosity db_stack False True
          if null es
-            then return []
+            then do when (not simple_output) $ do
+                      _ <- reportValidateErrors [] ws "" Nothing
+                      return ()
+                    return []
             else do
               when (not simple_output) $ do
                   reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":")
-                  _ <- reportValidateErrors es "  " Nothing
+                  _ <- reportValidateErrors es ws "  " Nothing
                   return ()
               return [p]
 
@@ -1146,43 +1269,49 @@ convertPackageInfoIn
 writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO ()
 writeNewConfig verbosity filename ipis = do
   when (verbosity >= Normal) $
-      hPutStr stdout "Writing new package config file... "
+      info "Writing new package config file... "
   createDirectoryIfMissing True $ takeDirectory filename
   let shown = concat $ intersperse ",\n "
                      $ map (show . convertPackageInfoOut) ipis
       fileContents = "[" ++ shown ++ "\n]"
   writeFileUtf8Atomic filename fileContents
-    `catch` \e ->
+    `catchIO` \e ->
       if isPermissionError e
       then die (filename ++ ": you don't have permission to modify this file")
       else ioError e
   when (verbosity >= Normal) $
-      hPutStrLn stdout "done."
+      infoLn "done."
 
 -----------------------------------------------------------------------------
 -- Sanity-check a new package config, and automatically build GHCi libs
 -- if requested.
 
-type ValidateError = (Force,String)
+type ValidateError   = (Force,String)
+type ValidateWarning = String
 
-newtype Validate a = V { runValidate :: IO (a, [ValidateError]) }
+newtype Validate a = V { runValidate :: IO (a, [ValidateError],[ValidateWarning]) }
 
 instance Monad Validate where
-   return a = V $ return (a, [])
+   return a = V $ return (a, [], [])
    m >>= k = V $ do
-      (a, es) <- runValidate m
-      (b, es') <- runValidate (k a)
-      return (b,es++es')
+      (a, es, ws) <- runValidate m
+      (b, es', ws') <- runValidate (k a)
+      return (b,es++es',ws++ws')
 
 verror :: Force -> String -> Validate ()
-verror f s = V (return ((),[(f,s)]))
+verror f s = V (return ((),[(f,s)],[]))
+
+vwarn :: String -> Validate ()
+vwarn s = V (return ((),[],["Warning: " ++ s]))
 
 liftIO :: IO a -> Validate a
-liftIO k = V (k >>= \a -> return (a,[]))
+liftIO k = V (k >>= \a -> return (a,[],[]))
 
 -- returns False if we should die
-reportValidateErrors :: [ValidateError] -> String -> Maybe Force -> IO Bool
-reportValidateErrors es prefix mb_force = do
+reportValidateErrors :: [ValidateError] -> [ValidateWarning]
+                     -> String -> Maybe Force -> IO Bool
+reportValidateErrors es ws prefix mb_force = do
+  mapM_ (warn . (prefix++)) ws
   oks <- mapM report es
   return (and oks)
   where
@@ -1202,32 +1331,37 @@ reportValidateErrors es prefix mb_force = do
              err = prefix ++ s
 
 validatePackageConfig :: InstalledPackageInfo
+                      -> Verbosity
                       -> PackageDBStack
                       -> Bool   -- auto-ghc-libs
                       -> Bool   -- update, or check
                       -> Force
                       -> IO ()
-validatePackageConfig pkg db_stack auto_ghci_libs update force = do
-  (_,es) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update
-  ok <- reportValidateErrors es (display (sourcePackageId pkg) ++ ": ") (Just force)
+validatePackageConfig pkg verbosity db_stack auto_ghci_libs update force = do
+  (_,es,ws) <- runValidate $ checkPackageConfig pkg verbosity db_stack auto_ghci_libs update
+  ok <- reportValidateErrors es ws (display (sourcePackageId pkg) ++ ": ") (Just force)
   when (not ok) $ exitWith (ExitFailure 1)
 
 checkPackageConfig :: InstalledPackageInfo
+                      -> Verbosity
                       -> PackageDBStack
                       -> Bool   -- auto-ghc-libs
                       -> Bool   -- update, or check
                       -> Validate ()
-checkPackageConfig pkg db_stack auto_ghci_libs update = do
+checkPackageConfig pkg verbosity db_stack auto_ghci_libs update = do
   checkInstalledPackageId pkg db_stack update
   checkPackageId pkg
   checkDuplicates db_stack pkg update
   mapM_ (checkDep db_stack) (depends pkg)
   checkDuplicateDepends (depends pkg)
-  mapM_ (checkDir "import-dirs") (importDirs pkg)
-  mapM_ (checkDir "library-dirs") (libraryDirs pkg)
-  mapM_ (checkDir "include-dirs") (includeDirs pkg)
+  mapM_ (checkDir False "import-dirs")  (importDirs pkg)
+  mapM_ (checkDir True  "library-dirs") (libraryDirs pkg)
+  mapM_ (checkDir True  "include-dirs") (includeDirs pkg)
+  mapM_ (checkDir True  "framework-dirs") (frameworkDirs pkg)
+  mapM_ (checkFile   True "haddock-interfaces") (haddockInterfaces pkg)
+  mapM_ (checkDirURL True "haddock-html")       (haddockHTMLs pkg)
   checkModules pkg
-  mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
+  mapM_ (checkHSLib verbosity (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
   -- ToDo: check these somehow?
   --    extra_libraries :: [String],
   --    c_includes      :: [String],
@@ -1277,16 +1411,38 @@ checkDuplicates db_stack pkg update = do
         "Package " ++ display pkgid ++
         " overlaps with: " ++ unwords (map display dups)
 
-
-checkDir :: String -> String -> Validate ()
-checkDir thisfield d
- | "$topdir"     `isPrefixOf` d = return ()
- | "$httptopdir" `isPrefixOf` d = return ()
-        -- can't check these, because we don't know what $(http)topdir is
+checkDir, checkFile, checkDirURL :: Bool -> String -> FilePath -> Validate ()
+checkDir  = checkPath False True
+checkFile = checkPath False False
+checkDirURL = checkPath True True
+
+checkPath :: Bool -> Bool -> Bool -> String -> FilePath -> Validate ()
+checkPath url_ok is_dir warn_only thisfield d
+ | url_ok && ("http://"  `isPrefixOf` d
+           || "https://" `isPrefixOf` d) = return ()
+
+ | url_ok
+ , Just d' <- stripPrefix "file://" d
+ = checkPath False is_dir warn_only thisfield d'
+
+   -- Note: we don't check for $topdir/${pkgroot} here. We rely on these
+   -- variables having been expanded already, see mungePackagePaths.
+
+ | isRelative d = verror ForceFiles $
+                     thisfield ++ ": " ++ d ++ " is a relative path which "
+                  ++ "makes no sense (as there is nothing for it to be "
+                  ++ "relative to). You can make paths relative to the "
+                  ++ "package database itself by using ${pkgroot}."
+        -- relative paths don't make any sense; #4134
  | otherwise = do
-   there <- liftIO $ doesDirectoryExist d
+   there <- liftIO $ if is_dir then doesDirectoryExist d else doesFileExist d
    when (not there) $
-       verror ForceFiles (thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory")
+       let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a "
+                                        ++ if is_dir then "directory" else "file"
+       in
+       if warn_only 
+          then vwarn msg
+          else verror ForceFiles msg
 
 checkDep :: PackageDBStack -> InstalledPackageId -> Validate ()
 checkDep db_stack pkgid
@@ -1305,14 +1461,14 @@ checkDuplicateDepends deps
   where
        dups = [ p | (p:_:_) <- group (sort deps) ]
 
-checkHSLib :: [String] -> Bool -> String -> Validate ()
-checkHSLib dirs auto_ghci_libs lib = do
+checkHSLib :: Verbosity -> [String] -> Bool -> String -> Validate ()
+checkHSLib verbosity dirs auto_ghci_libs lib = do
   let batch_lib_file = "lib" ++ lib ++ ".a"
   m <- liftIO $ doesFileExistOnPath batch_lib_file dirs
   case m of
     Nothing -> verror ForceFiles ("cannot find " ++ batch_lib_file ++
                                    " on library path")
-    Just dir -> liftIO $ checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs
+    Just dir -> liftIO $ checkGHCiLib verbosity dir batch_lib_file lib auto_ghci_libs
 
 doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath)
 doesFileExistOnPath file path = go path
@@ -1321,10 +1477,7 @@ doesFileExistOnPath file path = go path
                        if b then return (Just p) else go ps
 
 doesFileExistIn :: String -> String -> IO Bool
-doesFileExistIn lib d
- | "$topdir"     `isPrefixOf` d = return True
- | "$httptopdir" `isPrefixOf` d = return True
- | otherwise                = doesFileExist (d </> lib)
+doesFileExistIn lib d = doesFileExist (d </> lib)
 
 checkModules :: InstalledPackageInfo -> Validate ()
 checkModules pkg = do
@@ -1338,24 +1491,22 @@ checkModules pkg = do
       when (isNothing m) $
          verror ForceFiles ("file " ++ file ++ " is missing")
 
-checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO ()
-checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build
-  | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
-  | otherwise  = do
-      m <- doesFileExistOnPath ghci_lib_file dirs
-      when (isNothing m && ghci_lib_file /= "HSrts.o") $
-        hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file)
+checkGHCiLib :: Verbosity -> String -> String -> String -> Bool -> IO ()
+checkGHCiLib verbosity batch_lib_dir batch_lib_file lib auto_build
+  | auto_build = autoBuildGHCiLib verbosity batch_lib_dir batch_lib_file ghci_lib_file
+  | otherwise  = return ()
  where
     ghci_lib_file = lib <.> "o"
 
 -- automatically build the GHCi version of a batch lib,
 -- using ld --whole-archive.
 
-autoBuildGHCiLib :: String -> String -> String -> IO ()
-autoBuildGHCiLib dir batch_file ghci_file = do
+autoBuildGHCiLib :: Verbosity -> String -> String -> String -> IO ()
+autoBuildGHCiLib verbosity 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 ++ "...")
+  when (verbosity >= Normal) $
+    info ("building GHCi library " ++ ghci_lib_file ++ "...")
 #if defined(darwin_HOST_OS)
   r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
 #elif defined(mingw32_HOST_OS)
@@ -1365,7 +1516,8 @@ autoBuildGHCiLib dir batch_file ghci_file = do
   r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
 #endif
   when (r /= ExitSuccess) $ exitWith r
-  hPutStrLn stderr (" done.")
+  when (verbosity >= Normal) $
+    infoLn (" done.")
 
 -- -----------------------------------------------------------------------------
 -- Searching for modules
@@ -1378,7 +1530,7 @@ findModules paths =
   return (concat mms)
 
 searchDir path prefix = do
-  fs <- getDirectoryEntries path `catch` \_ -> return []
+  fs <- getDirectoryEntries path `catchIO` \_ -> return []
   searchEntries path prefix fs
 
 searchEntries path prefix [] = return []
@@ -1420,8 +1572,10 @@ expandEnvVars str0 force = go str0 ""
         = go str (c:acc)
 
    lookupEnvVar :: String -> IO String
+   lookupEnvVar "pkgroot"    = return "${pkgroot}"    -- these two are special,
+   lookupEnvVar "pkgrooturl" = return "${pkgrooturl}" -- we don't expand them
    lookupEnvVar nm =
-        catch (System.Environment.getEnv nm)
+        catchIO (System.Environment.getEnv nm)
            (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
                                         show nm)
                       return "")
@@ -1442,15 +1596,24 @@ die = dieWith 1
 
 dieWith :: Int -> String -> IO a
 dieWith ec s = do
-  hFlush stdout
   prog <- getProgramName
-  hPutStrLn stderr (prog ++ ": " ++ s)
+  reportError (prog ++ ": " ++ s)
   exitWith (ExitFailure ec)
 
 dieOrForceAll :: Force -> String -> IO ()
 dieOrForceAll ForceAll s = ignoreError s
 dieOrForceAll _other s   = dieForcible s
 
+warn :: String -> IO ()
+warn = reportError
+
+-- send info messages to stdout
+infoLn :: String -> IO ()
+infoLn = putStrLn
+
+info :: String -> IO ()
+info = putStr
+
 ignoreError :: String -> IO ()
 ignoreError s = reportError (s ++ " (ignoring)")
 
@@ -1488,16 +1651,17 @@ getExecDir cmd =
           removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
 
 getExecPath :: IO (Maybe String)
-getExecPath =
-     allocaArray len $ \buf -> do
-         ret <- getModuleFileName nullPtr buf len
-         if ret == 0 then return Nothing
-                    else liftM Just $ peekCString buf
-    where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
-
-foreign import stdcall unsafe "GetModuleFileNameA"
-    getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
-
+getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
+  where
+    try_size size = allocaArray (fromIntegral size) $ \buf -> do
+        ret <- c_GetModuleFileName nullPtr buf size
+        case ret of
+          0 -> return Nothing
+          _ | ret < size -> fmap Just $ peekCWString buf
+            | otherwise  -> try_size (size * 2)
+
+foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
+  c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
 #else
 getLibDir :: IO (Maybe String)
 getLibDir = return Nothing
@@ -1517,7 +1681,7 @@ installSignalHandlers = do
   _ <- installHandler sigQUIT (Catch interrupt) Nothing
   _ <- installHandler sigINT  (Catch interrupt) Nothing
   return ()
-#elif __GLASGOW_HASKELL__ >= 603
+#else
   -- GHC 6.3+ has support for console events on Windows
   -- NOTE: running GHCi under a bash shell for some reason requires
   -- you to press Ctrl-Break rather than Ctrl-C to provoke
@@ -1529,27 +1693,22 @@ installSignalHandlers = do
 
   _ <- installHandler (Catch sig_handler)
   return ()
-#else
-  return () -- nothing
-#endif
-
-#if __GLASGOW_HASKELL__ <= 604
-isInfixOf               :: (Eq a) => [a] -> [a] -> Bool
-isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)
 #endif
 
 #if mingw32_HOST_OS || mingw32_TARGET_OS
 throwIOIO :: Exception.IOException -> IO a
 throwIOIO = Exception.throwIO
+#endif
 
 catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
 catchIO = Exception.catch
-#endif
 
 catchError :: IO a -> (String -> IO a) -> IO a
 catchError io handler = io `Exception.catch` handler'
     where handler' (Exception.ErrorCall err) = handler err
 
+tryIO :: IO a -> IO (Either Exception.IOException a)
+tryIO = Exception.try
 
 writeBinaryFileAtomic :: Bin.Binary a => FilePath -> a -> IO ()
 writeBinaryFileAtomic targetFile obj =
@@ -1560,9 +1719,7 @@ writeBinaryFileAtomic targetFile obj =
 writeFileUtf8Atomic :: FilePath -> String -> IO ()
 writeFileUtf8Atomic targetFile content =
   withFileAtomic targetFile $ \h -> do
-#if __GLASGOW_HASKELL__ >= 612
      hSetEncoding h utf8
-#endif
      hPutStr h content
 
 -- copied from Cabal's Distribution.Simple.Utils, except that we want
@@ -1578,7 +1735,7 @@ withFileAtomic targetFile write_content = do
         `catchIO` \err -> do
           exists <- doesFileExist targetFile
           if exists
-            then do removeFile targetFile
+            then do removeFileSafe targetFile
                     -- Big fat hairy race condition
                     renameFile newFile targetFile
                     -- If the removeFile succeeds and the renameFile fails
@@ -1588,7 +1745,7 @@ withFileAtomic targetFile write_content = do
       renameFile newFile targetFile
 #endif
    `Exception.onException` do hClose newHandle
-                              removeFile newFile
+                              removeFileSafe newFile
   where
     template = targetName <.> "tmp"
     targetDir | null targetDir_ = "."
@@ -1599,71 +1756,10 @@ withFileAtomic targetFile write_content = do
 
 openNewFile :: FilePath -> String -> IO (FilePath, Handle)
 openNewFile dir template = do
-#if __GLASGOW_HASKELL__ >= 612
   -- this was added to System.IO in 6.12.1
   -- we must use this version because the version below opens the file
   -- in binary mode.
   openTempFileWithDefaultPermissions dir template
-#else
-  -- Ugh, this is a copy/paste of code from the base library, but
-  -- if uses 666 rather than 600 for the permissions.
-  pid <- c_getpid
-  findTempName pid
-  where
-    -- We split off the last extension, so we can use .foo.ext files
-    -- for temporary files (hidden on Unix OSes). Unfortunately we're
-    -- below filepath in the hierarchy here.
-    (prefix,suffix) =
-       case break (== '.') $ reverse template of
-         -- First case: template contains no '.'s. Just re-reverse it.
-         (rev_suffix, "")       -> (reverse rev_suffix, "")
-         -- Second case: template contains at least one '.'. Strip the
-         -- dot from the prefix and prepend it to the suffix (if we don't
-         -- do this, the unique number will get added after the '.' and
-         -- thus be part of the extension, which is wrong.)
-         (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)
-         -- Otherwise, something is wrong, because (break (== '.')) should
-         -- always return a pair with either the empty string or a string
-         -- beginning with '.' as the second component.
-         _                      -> error "bug in System.IO.openTempFile"
-
-    oflags = rw_flags .|. o_EXCL
-
-#if __GLASGOW_HASKELL__ < 611
-    withFilePath = withCString
-#endif
-
-    findTempName x = do
-      fd <- withFilePath filepath $ \ f ->
-              c_open f oflags 0o666
-      if fd < 0
-       then do
-         errno <- getErrno
-         if errno == eEXIST
-           then findTempName (x+1)
-           else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir))
-       else do
-         -- XXX We want to tell fdToHandle what the filepath is,
-         -- as any exceptions etc will only be able to report the
-         -- fd currently
-         h <-
-#if __GLASGOW_HASKELL__ >= 609
-              fdToHandle fd
-#else
-              fdToHandle (fromIntegral fd)
-#endif
-              `Exception.onException` c_close fd
-         return (filepath, h)
-      where
-        filename        = prefix ++ show x ++ suffix
-        filepath        = dir `combine` filename
-
--- XXX Copied from GHC.Handle
-std_flags, output_flags, rw_flags :: CInt
-std_flags    = o_NONBLOCK   .|. o_NOCTTY
-output_flags = std_flags    .|. o_CREAT
-rw_flags     = output_flags .|. o_RDWR
-#endif /* GLASGOW_HASKELL < 612 */
 
 -- | The function splits the given string to substrings
 -- using 'isSearchPathSeparator'.
@@ -1688,8 +1784,15 @@ parseSearchPath path = split path
 readUTF8File :: FilePath -> IO String
 readUTF8File file = do
   h <- openFile file ReadMode
-#if __GLASGOW_HASKELL__ >= 612
   -- fix the encoding to UTF-8
   hSetEncoding h utf8
-#endif
   hGetContents h
+
+-- removeFileSave doesn't throw an exceptions, if the file is already deleted
+removeFileSafe :: FilePath -> IO ()
+removeFileSafe fn =
+  removeFile fn `catchIO` \ e ->
+    when (not $ isDoesNotExistError e) $ ioError e
+
+absolutePath :: FilePath -> IO FilePath
+absolutePath path = return . normalise . (</> path) =<< getCurrentDirectory