The Backpack patch.
[ghc.git] / utils / ghc-pkg / Main.hs
index 52b7638..4a72ba7 100644 (file)
@@ -1,4 +1,8 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 -----------------------------------------------------------------------------
 --
 -- (c) The University of Glasgow 2004-2009.
 module Main (main) where
 
 import Version ( version, targetOS, targetARCH )
-import Distribution.InstalledPackageInfo.Binary()
+import qualified GHC.PackageDb as GhcPkg
+import GHC.PackageDb (BinaryStringRep(..))
 import qualified Distribution.Simple.PackageIndex as PackageIndex
-import Distribution.ModuleName hiding (main)
-import Distribution.InstalledPackageInfo
-import Distribution.Compat.ReadP
+import qualified Data.Graph as Graph
+import qualified Distribution.ModuleName as ModuleName
+import Distribution.ModuleName (ModuleName)
+import Distribution.InstalledPackageInfo as Cabal
+import Distribution.Compat.ReadP hiding (get)
 import Distribution.ParseUtils
-import Distribution.ModuleExport
-import Distribution.Package hiding (depends)
+import Distribution.Package hiding (installedUnitId)
 import Distribution.Text
 import Distribution.Version
+import Distribution.Backpack
+import Distribution.Simple.Utils (fromUTF8, toUTF8, writeUTF8File, readUTF8File)
+import qualified Data.Version as Version
 import System.FilePath as FilePath
 import qualified System.FilePath.Posix as FilePath.Posix
-import System.Process
 import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing,
                           getModificationTime )
 import Text.Printf
@@ -33,25 +41,22 @@ import System.Console.GetOpt
 import qualified Control.Exception as Exception
 import Data.Maybe
 
-import qualified Data.Set as Set
-
 import Data.Char ( isSpace, toLower )
-import Data.Ord (comparing)
-import Control.Applicative (Applicative(..))
 import Control.Monad
 import System.Directory ( doesDirectoryExist, getDirectoryContents,
-                          doesFileExist, renameFile, removeFile,
+                          doesFileExist, removeFile,
                           getCurrentDirectory )
 import System.Exit ( exitWith, ExitCode(..) )
 import System.Environment ( getArgs, getProgName, getEnv )
 import System.IO
 import System.IO.Error
+import GHC.IO.Exception (IOErrorType(InappropriateType))
 import Data.List
 import Control.Concurrent
+import qualified Data.Set as Set
+import qualified Data.Map as Map
 
-import qualified Data.ByteString.Lazy as B
-import qualified Data.Binary as Bin
-import qualified Data.Binary.Get as Bin
+import qualified Data.ByteString.Char8 as BS
 
 #if defined(mingw32_HOST_OS)
 -- mingw32 needs these for getExecDir
@@ -83,6 +88,15 @@ import System.Console.Terminfo as Terminfo
 # endif
 #endif
 
+-- | Short-circuit 'any' with a \"monadic predicate\".
+anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
+anyM _ [] = return False
+anyM p (x:xs) = do
+  b <- p x
+  if b
+    then return True
+    else anyM p xs
+
 -- -----------------------------------------------------------------------------
 -- Entry point
 
@@ -117,7 +131,6 @@ data Flag
   | FlagUserConfig FilePath
   | FlagForce
   | FlagForceFiles
-  | FlagAutoGHCiLibs
   | FlagMultiInstance
   | FlagExpandEnvVars
   | FlagExpandPkgroot
@@ -127,6 +140,7 @@ data Flag
   | FlagIgnoreCase
   | FlagNoUserDb
   | FlagVerbosity (Maybe String)
+  | FlagUnitId
   deriving Eq
 
 flags :: [OptDescr Flag]
@@ -151,8 +165,6 @@ flags = [
          "ignore missing dependencies, directories, and libraries",
   Option [] ["force-files"] (NoArg FlagForceFiles)
          "ignore missing directories and libraries only",
-  Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
-        "automatically build libs for GHCi (with register)",
   Option [] ["enable-multi-instance"] (NoArg FlagMultiInstance)
         "allow registering multiple instances of the same package version",
   Option [] ["expand-env-vars"] (NoArg FlagExpandEnvVars)
@@ -171,6 +183,8 @@ flags = [
         "only print package names, not versions; can only be used with list --simple-output",
   Option [] ["ignore-case"] (NoArg FlagIgnoreCase)
         "ignore case for substring matching",
+  Option [] ["ipid", "unit-id"] (NoArg FlagUnitId)
+        "interpret package arguments as unit IDs (e.g. installed package IDs)",
   Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity")
         "verbosity level (0-2, default 1)"
   ]
@@ -216,8 +230,8 @@ usageHeader prog = substProg prog $
   "    Register the package, overwriting any other package with the\n" ++
   "    same name. The input file should be encoded in UTF-8.\n" ++
   "\n" ++
-  "  $p unregister {pkg-id}\n" ++
-  "    Unregister the specified package.\n" ++
+  "  $p unregister [pkg-id] \n" ++
+  "    Unregister the specified packages in the order given.\n" ++
   "\n" ++
   "  $p expose {pkg-id}\n" ++
   "    Expose the specified package.\n" ++
@@ -279,7 +293,8 @@ usageHeader prog = substProg prog $
   "\n" ++
   " Substring matching is supported for {module} in find-module and\n" ++
   " for {pkg} in list, describe, and field, where a '*' indicates\n" ++
-  " open substring ends (prefix*, *suffix, *infix*).\n" ++
+  " open substring ends (prefix*, *suffix, *infix*).  Use --ipid to\n" ++
+  " match against the installed package ID instead.\n" ++
   "\n" ++
   "  When asked to modify a database (register, unregister, update,\n"++
   "  hide, expose, and also check), ghc-pkg modifies the global database by\n"++
@@ -306,25 +321,43 @@ substProg prog (c:xs) = c : substProg prog xs
 data Force = NoForce | ForceFiles | ForceAll | CannotForce
   deriving (Eq,Ord)
 
-data PackageArg = Id PackageIdentifier | Substring String (String->Bool)
+-- | Enum flag representing argument type
+data AsPackageArg
+    = AsUnitId
+    | AsDefault
+
+-- | Represents how a package may be specified by a user on the command line.
+data PackageArg
+    -- | A package identifier foo-0.1, or a glob foo-*
+    = Id GlobPackageIdentifier
+    -- | An installed package ID foo-0.1-HASH.  This is guaranteed to uniquely
+    -- match a single entry in the package database.
+    | IUId UnitId
+    -- | A glob against the package name.  The first string is the literal
+    -- glob, the second is a function which returns @True@ if the argument
+    -- matches.
+    | Substring String (String->Bool)
 
 runit :: Verbosity -> [Flag] -> [String] -> IO ()
 runit verbosity cli nonopts = do
   installSignalHandlers -- catch ^C and clean up
+  when (verbosity >= Verbose)
+    (putStr ourCopyright)
   prog <- getProgramName
   let
         force
           | FlagForce `elem` cli        = ForceAll
           | FlagForceFiles `elem` cli   = ForceFiles
           | otherwise                   = NoForce
-        auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
+        as_arg | FlagUnitId `elem` cli = AsUnitId
+               | otherwise             = AsDefault
         multi_instance = FlagMultiInstance `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)
@@ -387,51 +420,53 @@ runit verbosity cli nonopts = do
         initPackageDB filename verbosity cli
     ["register", filename] ->
         registerPackage filename verbosity cli
-                        auto_ghci_libs multi_instance
+                        multi_instance
                         expand_env_vars False force
     ["update", filename] ->
         registerPackage filename verbosity cli
-                        auto_ghci_libs multi_instance
+                        multi_instance
                         expand_env_vars True force
-    ["unregister", pkgid_str] -> do
-        pkgid <- readGlobPkgId pkgid_str
-        unregisterPackage pkgid verbosity cli force
-    ["expose", pkgid_str] -> do
-        pkgid <- readGlobPkgId pkgid_str
-        exposePackage pkgid verbosity cli force
-    ["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
+    "unregister" : pkgarg_strs@(_:_) -> do
+        forM_ pkgarg_strs $ \pkgarg_str -> do
+          pkgarg <- readPackageArg as_arg pkgarg_str
+          unregisterPackage pkgarg verbosity cli force
+    ["expose", pkgarg_str] -> do
+        pkgarg <- readPackageArg as_arg pkgarg_str
+        exposePackage pkgarg verbosity cli force
+    ["hide",   pkgarg_str] -> do
+        pkgarg <- readPackageArg as_arg pkgarg_str
+        hidePackage pkgarg verbosity cli force
+    ["trust",    pkgarg_str] -> do
+        pkgarg <- readPackageArg as_arg pkgarg_str
+        trustPackage pkgarg verbosity cli force
+    ["distrust", pkgarg_str] -> do
+        pkgarg <- readPackageArg as_arg pkgarg_str
+        distrustPackage pkgarg verbosity cli force
     ["list"] -> do
         listPackages verbosity cli Nothing Nothing
-    ["list", pkgid_str] ->
-        case substringCheck pkgid_str of
-          Nothing -> do pkgid <- readGlobPkgId pkgid_str
-                        listPackages verbosity cli (Just (Id pkgid)) Nothing
-          Just m -> listPackages verbosity cli (Just (Substring pkgid_str m)) Nothing
+    ["list", pkgarg_str] ->
+        case substringCheck pkgarg_str of
+          Nothing -> do pkgarg <- readPackageArg as_arg pkgarg_str
+                        listPackages verbosity cli (Just pkgarg) Nothing
+          Just m -> listPackages verbosity cli
+                                 (Just (Substring pkgarg_str m)) Nothing
     ["dot"] -> do
         showPackageDot verbosity cli
-    ["find-module", moduleName] -> do
-        let match = maybe (==moduleName) id (substringCheck moduleName)
+    ["find-module", mod_name] -> do
+        let match = maybe (==mod_name) id (substringCheck mod_name)
         listPackages verbosity cli Nothing (Just match)
     ["latest", pkgid_str] -> do
         pkgid <- readGlobPkgId pkgid_str
         latestPackage verbosity cli pkgid
     ["describe", pkgid_str] -> do
         pkgarg <- case substringCheck pkgid_str of
-          Nothing -> liftM Id (readGlobPkgId pkgid_str)
+          Nothing -> readPackageArg as_arg 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)
+          Nothing -> readPackageArg as_arg pkgid_str
           Just m  -> return (Substring pkgid_str m)
         describeField verbosity cli pkgarg
                       (splitFields fields) (fromMaybe True mexpand_pkgroot)
@@ -456,20 +491,31 @@ parseCheck parser str what =
     [x] -> return x
     _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)
 
-readGlobPkgId :: String -> IO PackageIdentifier
+-- | Either an exact 'PackageIdentifier', or a glob for all packages
+-- matching 'PackageName'.
+data GlobPackageIdentifier
+    = ExactPackageIdentifier PackageIdentifier
+    | GlobPackageIdentifier  PackageName
+
+displayGlobPkgId :: GlobPackageIdentifier -> String
+displayGlobPkgId (ExactPackageIdentifier pid) = display pid
+displayGlobPkgId (GlobPackageIdentifier pn) = display pn ++ "-*"
+
+readGlobPkgId :: String -> IO GlobPackageIdentifier
 readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"
 
-parseGlobPackageId :: ReadP r PackageIdentifier
+parseGlobPackageId :: ReadP r GlobPackageIdentifier
 parseGlobPackageId =
-  parse
+  fmap ExactPackageIdentifier parse
      +++
   (do n <- parse
       _ <- string "-*"
-      return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
+      return (GlobPackageIdentifier n))
 
--- globVersion means "all versions"
-globVersion :: Version
-globVersion = Version{ versionBranch=[], versionTags=["*"] }
+readPackageArg :: AsPackageArg -> String -> IO PackageArg
+readPackageArg AsUnitId str =
+    parseCheck (IUId `fmap` parse) str "installed package id"
+readPackageArg AsDefault str = Id `fmap` readGlobPkgId str
 
 -- -----------------------------------------------------------------------------
 -- Package databases
@@ -483,7 +529,7 @@ globVersion = Version{ versionBranch=[], versionTags=["*"] }
 -- Some commands operate  on multiple databases, with overlapping semantics:
 --      list, describe, field
 
-data PackageDB 
+data PackageDB
   = PackageDB {
       location, locationAbsolute :: !FilePath,
       -- We need both possibly-relative and definately-absolute package
@@ -491,7 +537,7 @@ data PackageDB
       -- 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]
     }
 
@@ -504,11 +550,12 @@ allPackagesInStack = concatMap packages
 
 getPkgDatabases :: Verbosity
                 -> Bool    -- we are modifying, not reading
+                -> Bool    -- use the user db
                 -> Bool    -- read caches, if available
                 -> Bool    -- expand vars, like ${pkgroot} and $topdir
                 -> [Flag]
-                -> IO (PackageDBStack, 
-                          -- the real package DB stack: [global,user] ++ 
+                -> IO (PackageDBStack,
+                          -- the real package DB stack: [global,user] ++
                           -- DBs specified on the command line with -f.
                        Maybe FilePath,
                           -- which one to modify, if any
@@ -518,7 +565,7 @@ 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 expand_vars my_flags = do
+getPkgDatabases verbosity modify use_user 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-package-db flag by the
@@ -562,21 +609,23 @@ getPkgDatabases verbosity modify use_cache expand_vars my_flags = do
             Just f  -> return (Just (f, True))
       fs -> return (Just (last fs, True))
 
-  -- If the user database doesn't exist, and this command isn't a
-  -- "modify" command, then we won't attempt to create or use it.
+  -- If the user database exists, and for "use_user" commands (which includes
+  -- "ghc-pkg check" and all commands that modify the db) we will attempt to
+  -- use the user db.
   let sys_databases
         | Just (user_conf,user_exists) <- mb_user_conf,
-          modify || user_exists = [user_conf, global_conf]
-        | otherwise             = [global_conf]
+          use_user || user_exists = [user_conf, global_conf]
+        | otherwise               = [global_conf]
 
   e_pkg_path <- tryIO (System.Environment.getEnv "GHC_PACKAGE_PATH")
   let env_stack =
         case e_pkg_path of
                 Left  _ -> sys_databases
                 Right path
-                  | last cs == ""  -> init cs ++ sys_databases
-                  | otherwise      -> cs
-                  where cs = parseSearchPath path
+                  | not (null path) && isSearchPathSeparator (last path)
+                  -> splitSearchPath (init path) ++ sys_databases
+                  | otherwise
+                  -> splitSearchPath path
 
         -- The "global" database is always the one at the bottom of the stack.
         -- This is the database we modify by default.
@@ -584,7 +633,7 @@ getPkgDatabases verbosity modify use_cache expand_vars my_flags = do
 
   let db_flags = [ f | Just f <- map is_db_flag my_flags ]
          where is_db_flag FlagUser
-                      | Just (user_conf, _user_exists) <- mb_user_conf 
+                      | Just (user_conf, _user_exists) <- mb_user_conf
                       = Just user_conf
                is_db_flag FlagGlobal     = Just virt_global_conf
                is_db_flag (FlagConfig f) = Just f
@@ -613,7 +662,7 @@ getPkgDatabases verbosity modify use_cache expand_vars my_flags = do
         | otherwise     = Just (last db_flags)
 
   db_stack  <- sequence
-    [ do db <- readParseDatabase verbosity mb_user_conf use_cache db_path
+    [ do db <- readParseDatabase verbosity mb_user_conf modify use_cache db_path
          if expand_vars then return (mungePackageDBPaths top_dir db)
                         else return db
     | db_path <- final_stack ]
@@ -640,20 +689,32 @@ lookForPackageDBIn dir = do
 
 readParseDatabase :: Verbosity
                   -> Maybe (FilePath,Bool)
+                  -> Bool -- we will be modifying, not just reading
                   -> Bool -- use cache
                   -> FilePath
                   -> IO PackageDB
 
-readParseDatabase verbosity mb_user_conf use_cache path
+readParseDatabase verbosity mb_user_conf modify use_cache path
   -- the user database (only) is allowed to be non-existent
   | Just (user_conf,False) <- mb_user_conf, path == user_conf
   = mkPackageDB []
   | otherwise
   = do e <- tryIO $ getDirectoryContents path
        case e of
-         Left _   -> do
-              pkgs <- parseMultiPackageConf verbosity path
-              mkPackageDB pkgs
+         Left err
+           | ioeGetErrorType err == InappropriateType -> do
+              -- We provide a limited degree of backwards compatibility for
+              -- old single-file style db:
+              mdb <- tryReadParseOldFileStyleDatabase verbosity
+                       mb_user_conf modify use_cache path
+              case mdb of
+                Just db -> return db
+                Nothing ->
+                  die $ "ghc no longer supports single-file style package "
+                     ++ "databases (" ++ path ++ ") use 'ghc-pkg init'"
+                     ++ "to create the database with the correct format."
+
+           | otherwise -> ioError err
          Right fs
            | not use_cache -> ignore_cache (const $ return ())
            | otherwise -> do
@@ -662,9 +723,16 @@ readParseDatabase verbosity mb_user_conf use_cache path
               e_tcache <- tryIO $ getModificationTime cache
               case e_tcache of
                 Left ex -> do
-                     when (verbosity > Normal) $
-                        warn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex)
-                     ignore_cache (const $ return ())
+                  whenReportCacheErrors $
+                    if isDoesNotExistError ex
+                      then do
+                        warn ("WARNING: cache does not exist: " ++ cache)
+                        warn ("ghc will fail to read this package db. " ++
+                              recacheAdvice)
+                      else do
+                        warn ("WARNING: cache cannot be read: " ++ show ex)
+                        warn "ghc will fail to read this package db."
+                  ignore_cache (const $ return ())
                 Right tcache -> do
                   let compareTimestampToCache file =
                           when (verbosity >= Verbose) $ do
@@ -684,14 +752,13 @@ readParseDatabase verbosity mb_user_conf use_cache path
                       then do
                           when (verbosity > Normal) $
                              infoLn ("using cache: " ++ cache)
-                          pkgs <- myReadBinPackageDB cache
-                          let pkgs' = map convertPackageInfoIn pkgs
-                          mkPackageDB pkgs'
+                          pkgs <- GhcPkg.readPackageDbForGhcPkg cache
+                          mkPackageDB pkgs
                       else do
-                          when (verbosity >= Normal) $ do
-                              warn ("WARNING: cache is out of date: "
-                                 ++ cache)
-                              warn "Use 'ghc-pkg recache' to fix."
+                          whenReportCacheErrors $ do
+                              warn ("WARNING: cache is out of date: " ++ cache)
+                              warn ("ghc will see an old view of this " ++
+                                    "package db. " ++ recacheAdvice)
                           ignore_cache compareTimestampToCache
             where
                  ignore_cache :: (FilePath -> IO ()) -> IO PackageDB
@@ -701,7 +768,19 @@ readParseDatabase verbosity mb_user_conf use_cache path
                                        parseSingletonPackageConf verbosity f
                      pkgs <- mapM doFile $ map (path </>) confs
                      mkPackageDB pkgs
+
+                 -- We normally report cache errors for read-only commands,
+                 -- since modify commands because will usually fix the cache.
+                 whenReportCacheErrors =
+                     when (   verbosity >  Normal
+                           || verbosity >= Normal && not modify)
   where
+    recacheAdvice
+      | Just (user_conf, True) <- mb_user_conf, path == user_conf
+      = "Use 'ghc-pkg recache --user' to fix."
+      | otherwise
+      = "Use 'ghc-pkg recache' to fix."
+
     mkPackageDB pkgs = do
       path_abs <- absolutePath path
       return PackageDB {
@@ -710,27 +789,6 @@ readParseDatabase verbosity mb_user_conf use_cache path
         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
--- after it has been completely read, leading to a sharing violation
--- later.
-myReadBinPackageDB :: FilePath -> IO [InstalledPackageInfoString]
-myReadBinPackageDB filepath = do
-  h <- openBinaryFile filepath ReadMode
-  sz <- hFileSize h
-  b <- B.hGet h (fromIntegral sz)
-  hClose h
-  return $ Bin.runGet Bin.get b
-
-parseMultiPackageConf :: Verbosity -> FilePath -> IO [InstalledPackageInfo]
-parseMultiPackageConf verbosity file = do
-  when (verbosity > Normal) $ infoLn ("reading package database: " ++ file)
-  str <- readUTF8File file
-  let pkgs = map convertPackageInfoIn $ read str
-  Exception.evaluate pkgs
-    `catchError` \e->
-       die ("error while parsing " ++ file ++ ": " ++ show e)
-  
 parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
 parseSingletonPackageConf verbosity file = do
   when (verbosity > Normal) $ infoLn ("reading package config: " ++ file)
@@ -743,7 +801,7 @@ mungePackageDBPaths :: FilePath -> PackageDB -> PackageDB
 mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } =
     db { packages = map (mungePackagePaths top_dir pkgroot) pkgs }
   where
-    pkgroot = takeDirectory (locationAbsolute db)    
+    pkgroot = takeDirectory $ dropTrailingPathSeparator (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/
@@ -801,6 +859,67 @@ mungePackagePaths top_dir pkgroot pkg =
 
 
 -- -----------------------------------------------------------------------------
+-- Workaround for old single-file style package dbs
+
+-- Single-file style package dbs have been deprecated for some time, but
+-- it turns out that Cabal was using them in one place. So this code is for a
+-- workaround to allow older Cabal versions to use this newer ghc.
+
+-- We check if the file db contains just "[]" and if so, we look for a new
+-- dir-style db in path.d/, ie in a dir next to the given file.
+-- We cannot just replace the file with a new dir style since Cabal still
+-- assumes it's a file and tries to overwrite with 'writeFile'.
+
+-- ghc itself also cooperates in this workaround
+
+tryReadParseOldFileStyleDatabase :: Verbosity -> Maybe (FilePath, Bool)
+                                 -> Bool -> Bool -> FilePath
+                                 -> IO (Maybe PackageDB)
+tryReadParseOldFileStyleDatabase verbosity mb_user_conf modify use_cache path = do
+  -- assumes we've already established that path exists and is not a dir
+  content <- readFile path `catchIO` \_ -> return ""
+  if take 2 content == "[]"
+    then do
+      path_abs <- absolutePath path
+      let path_dir = path <.> "d"
+      warn $ "Warning: ignoring old file-style db and trying " ++ path_dir
+      direxists <- doesDirectoryExist path_dir
+      if direxists
+         then do db <- readParseDatabase verbosity mb_user_conf
+                                   modify use_cache path_dir
+                 -- but pretend it was at the original location
+                 return $ Just db {
+                   location         = path,
+                   locationAbsolute = path_abs
+                 }
+         else   return $ Just PackageDB {
+                   location         = path,
+                   locationAbsolute = path_abs,
+                   packages         = []
+                 }
+
+    -- if the path is not a file, or is not an empty db then we fail
+    else return Nothing
+
+adjustOldFileStylePackageDB :: PackageDB -> IO PackageDB
+adjustOldFileStylePackageDB db = do
+  -- assumes we have not yet established if it's an old style or not
+  mcontent <- liftM Just (readFile (location db)) `catchIO` \_ -> return Nothing
+  case fmap (take 2) mcontent of
+    -- it is an old style and empty db, so look for a dir kind in location.d/
+    Just "[]" -> return db {
+                   location         = location db <.> "d",
+                   locationAbsolute = locationAbsolute db <.> "d"
+                 }
+    -- it is old style but not empty, we have to bail
+    Just  _   -> die $ "ghc no longer supports single-file style package "
+                    ++ "databases (" ++ location db ++ ") use 'ghc-pkg init'"
+                    ++ "to create the database with the correct format."
+    -- probably not old style, carry on as normal
+    Nothing   -> return db
+
+
+-- -----------------------------------------------------------------------------
 -- Creating a new package DB
 
 initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO ()
@@ -822,24 +941,20 @@ initPackageDB filename verbosity _flags = do
 registerPackage :: FilePath
                 -> Verbosity
                 -> [Flag]
-                -> Bool              -- auto_ghci_libs
                 -> Bool              -- multi_instance
                 -> Bool              -- expand_env_vars
                 -> Bool              -- update
                 -> Force
                 -> IO ()
-registerPackage input verbosity my_flags auto_ghci_libs multi_instance
+registerPackage input verbosity my_flags multi_instance
                 expand_env_vars update force = do
-  (db_stack, Just to_modify, _flag_dbs) <- 
-      getPkgDatabases verbosity True True False{-expand vars-} my_flags
+  (db_stack, Just to_modify, _flag_dbs) <-
+      getPkgDatabases verbosity True{-modify-} True{-use user-}
+                                True{-use cache-} 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
@@ -861,7 +976,7 @@ registerPackage input verbosity my_flags auto_ghci_libs multi_instance
       infoLn "done."
 
   -- report any warnings from the parse phase
-  _ <- reportValidateErrors [] ws
+  _ <- reportValidateErrors verbosity [] ws
          (display (sourcePackageId pkg) ++ ": Warning: ") Nothing
 
   -- validate the expanded pkg, but register the unexpanded
@@ -873,12 +988,9 @@ registerPackage input verbosity my_flags auto_ghci_libs multi_instance
   -- truncate the stack for validation, because we don't allow
   -- packages lower in the stack to refer to those higher up.
   validatePackageConfig pkg_expanded verbosity truncated_stack
-                        auto_ghci_libs multi_instance update force
+                        multi_instance update force
 
-  -- postprocess the package
-  pkg' <- resolveReexports truncated_stack pkg
-
-  let 
+  let
      -- In the normal mode, we only allow one version of each package, so we
      -- remove all instances with the same source package id as the one we're
      -- adding. In the multi instance mode we don't do that, thus allowing
@@ -888,14 +1000,14 @@ registerPackage input verbosity my_flags auto_ghci_libs multi_instance
                  p <- packages db_to_operate_on,
                  sourcePackageId p == sourcePackageId pkg ]
   --
-  changeDB verbosity (removes ++ [AddPackage pkg']) db_to_operate_on
+  changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on
 
 parsePackageInfo
         :: String
         -> IO (InstalledPackageInfo, [ValidateWarning])
 parsePackageInfo str =
   case parseInstalledPackageInfo str of
-    ParseOk warnings ok -> return (ok, ws)
+    ParseOk warnings ok -> return (mungePackageInfo ok, ws)
       where
         ws = [ msg | PWarning msg <- warnings
                    , not ("Unrecognized field pkgroot" `isPrefixOf` msg) ]
@@ -903,46 +1015,8 @@ parsePackageInfo str =
                            (Nothing, s) -> die s
                            (Just l, s) -> die (show l ++ ": " ++ s)
 
--- | Takes the "reexported-modules" field of an InstalledPackageInfo
--- and resolves the references so they point to the original exporter
--- of a module (i.e. the module is in exposed-modules, not
--- reexported-modules).  This is done by maintaining an invariant on
--- the installed package database that a reexported-module field always
--- points to the original exporter.
-resolveReexports :: PackageDBStack
-                 -> InstalledPackageInfo
-                 -> IO InstalledPackageInfo
-resolveReexports db_stack pkg = do
-  let dep_mask = Set.fromList (depends pkg)
-      deps = filter (flip Set.member dep_mask . installedPackageId)
-                    (allPackagesInStack db_stack)
-      matchExposed pkg_dep m = map ((,) (installedPackageId pkg_dep))
-                                   (filter (==m) (exposedModules pkg_dep))
-      worker ModuleExport{ exportOrigPackageName = Just pnm } pkg_dep
-        | pnm /= packageName (sourcePackageId pkg_dep) = []
-      -- Now, either the package matches, *or* we were asked to search the
-      -- true location ourselves.
-      worker ModuleExport{ exportOrigName = m } pkg_dep =
-            matchExposed pkg_dep m ++
-            map (fromMaybe (error $ "Impossible! Missing true location in " ++
-                                    display (installedPackageId pkg_dep))
-                    . exportCachedTrueOrig)
-                (filter ((==m) . exportName) (reexportedModules pkg_dep))
-      self_reexports ModuleExport{ exportOrigPackageName = Just pnm }
-        | pnm /= packageName (sourcePackageId pkg) = []
-      self_reexports ModuleExport{ exportName = m', exportOrigName = m }
-        -- Self-reexport without renaming doesn't make sense
-        | m == m' = []
-        -- *Only* match against exposed modules!
-        | otherwise = matchExposed pkg m
-
-  r <- forM (reexportedModules pkg) $ \me -> do
-    case nub (concatMap (worker me) deps ++ self_reexports me) of
-      [c] -> return me { exportCachedTrueOrig = Just c }
-      [] -> die $ "Couldn't resolve reexport " ++ display me
-      cs -> die $ "Found multiple possible ways to resolve reexport " ++
-                  display me ++ ": " ++ show cs
-  return (pkg { reexportedModules = r })
+mungePackageInfo :: InstalledPackageInfo -> InstalledPackageInfo
+mungePackageInfo ipi = ipi
 
 -- -----------------------------------------------------------------------------
 -- Making changes to a package database
@@ -954,22 +1028,19 @@ data DBOp = RemovePackage InstalledPackageInfo
 changeDB :: Verbosity -> [DBOp] -> PackageDB -> IO ()
 changeDB verbosity cmds db = do
   let db' = updateInternalDB db cmds
-  isfile <- doesFileExist (location db)
-  if isfile
-     then writeNewConfig verbosity (location db') (packages db')
-     else do
-       createDirectoryIfMissing True (location db)
-       changeDBDir verbosity cmds db'
+  db'' <- adjustOldFileStylePackageDB db'
+  createDirectoryIfMissing True (location db'')
+  changeDBDir verbosity cmds db''
 
 updateInternalDB :: PackageDB -> [DBOp] -> PackageDB
 updateInternalDB db cmds = db{ packages = foldl do_cmd (packages db) cmds }
  where
-  do_cmd pkgs (RemovePackage p) = 
-    filter ((/= installedPackageId p) . installedPackageId) pkgs
+  do_cmd pkgs (RemovePackage p) =
+    filter ((/= installedUnitId p) . installedUnitId) pkgs
   do_cmd pkgs (AddPackage p) = p : pkgs
-  do_cmd pkgs (ModifyPackage p) = 
+  do_cmd pkgs (ModifyPackage p) =
     do_cmd (do_cmd pkgs (RemovePackage p)) (AddPackage p)
-    
+
 
 changeDBDir :: Verbosity -> [DBOp] -> PackageDB -> IO ()
 changeDBDir verbosity cmds db = do
@@ -977,89 +1048,184 @@ changeDBDir verbosity cmds db = do
   updateDBCache verbosity db
  where
   do_cmd (RemovePackage p) = do
-    let file = location db </> display (installedPackageId p) <.> "conf"
+    let file = location db </> display (installedUnitId p) <.> "conf"
     when (verbosity > Normal) $ infoLn ("removing " ++ file)
     removeFileSafe file
   do_cmd (AddPackage p) = do
-    let file = location db </> display (installedPackageId p) <.> "conf"
+    let file = location db </> display (installedUnitId p) <.> "conf"
     when (verbosity > Normal) $ infoLn ("writing " ++ file)
-    writeFileUtf8Atomic file (showInstalledPackageInfo p)
-  do_cmd (ModifyPackage p) = 
+    writeUTF8File file (showInstalledPackageInfo p)
+  do_cmd (ModifyPackage p) =
     do_cmd (AddPackage p)
 
 updateDBCache :: Verbosity -> PackageDB -> IO ()
 updateDBCache verbosity db = do
   let filename = location db </> cachefilename
+
+      pkgsCabalFormat :: [InstalledPackageInfo]
+      pkgsCabalFormat = packages db
+
+      pkgsGhcCacheFormat :: [PackageCacheFormat]
+      pkgsGhcCacheFormat = map convertPackageInfoToCacheFormat pkgsCabalFormat
+
   when (verbosity > Normal) $
       infoLn ("writing cache " ++ filename)
-  writeBinaryFileAtomic filename (map convertPackageInfoOut (packages db))
+  GhcPkg.writePackageDb filename pkgsGhcCacheFormat pkgsCabalFormat
     `catchIO` \e ->
       if isPermissionError e
       then die (filename ++ ": you don't have permission to modify this file")
       else ioError e
-#ifndef mingw32_HOST_OS
-  status <- getFileStatus filename
-  setFileTimes (location db) (accessTime status) (modificationTime status)
-#endif
+  -- See Note [writeAtomic leaky abstraction]
+  -- Cross-platform "touch". This only works if filename is not empty, and not
+  -- open for writing already.
+  -- TODO. When the Win32 or directory packages have either a touchFile or a
+  -- setModificationTime function, use one of those.
+  withBinaryFile filename ReadWriteMode $ \handle -> do
+      c <- hGetChar handle
+      hSeek handle AbsoluteSeek 0
+      hPutChar handle c
+
+type PackageCacheFormat = GhcPkg.InstalledPackageInfo
+                            ComponentId
+                            PackageIdentifier
+                            PackageName
+                            UnitId
+                            OpenUnitId
+                            ModuleName
+                            OpenModule
+
+convertPackageInfoToCacheFormat :: InstalledPackageInfo -> PackageCacheFormat
+convertPackageInfoToCacheFormat pkg =
+    GhcPkg.InstalledPackageInfo {
+       GhcPkg.unitId             = installedUnitId pkg,
+       GhcPkg.instantiatedWith   = instantiatedWith pkg,
+       GhcPkg.sourcePackageId    = sourcePackageId pkg,
+       GhcPkg.packageName        = packageName pkg,
+       GhcPkg.packageVersion     = Version.Version (versionNumbers (packageVersion pkg)) [],
+       GhcPkg.depends            = depends pkg,
+       GhcPkg.abiHash            = unAbiHash (abiHash pkg),
+       GhcPkg.importDirs         = importDirs pkg,
+       GhcPkg.hsLibraries        = hsLibraries pkg,
+       GhcPkg.extraLibraries     = extraLibraries pkg,
+       GhcPkg.extraGHCiLibraries = extraGHCiLibraries pkg,
+       GhcPkg.libraryDirs        = libraryDirs pkg,
+       GhcPkg.frameworks         = frameworks pkg,
+       GhcPkg.frameworkDirs      = frameworkDirs pkg,
+       GhcPkg.ldOptions          = ldOptions pkg,
+       GhcPkg.ccOptions          = ccOptions pkg,
+       GhcPkg.includes           = includes pkg,
+       GhcPkg.includeDirs        = includeDirs pkg,
+       GhcPkg.haddockInterfaces  = haddockInterfaces pkg,
+       GhcPkg.haddockHTMLs       = haddockHTMLs pkg,
+       GhcPkg.exposedModules     = map convertExposed (exposedModules pkg),
+       GhcPkg.hiddenModules      = hiddenModules pkg,
+       GhcPkg.exposed            = exposed pkg,
+       GhcPkg.trusted            = trusted pkg
+    }
+  where convertExposed (ExposedModule n reexport) = (n, reexport)
+
+instance GhcPkg.BinaryStringRep ComponentId where
+  fromStringRep = mkComponentId . fromStringRep
+  toStringRep   = toStringRep . display
+
+instance GhcPkg.BinaryStringRep PackageName where
+  fromStringRep = mkPackageName . fromStringRep
+  toStringRep   = toStringRep . display
+
+instance GhcPkg.BinaryStringRep PackageIdentifier where
+  fromStringRep = fromMaybe (error "BinaryStringRep PackageIdentifier")
+                . simpleParse . fromStringRep
+  toStringRep = toStringRep . display
+
+instance GhcPkg.BinaryStringRep ModuleName where
+  fromStringRep = ModuleName.fromString . fromStringRep
+  toStringRep   = toStringRep . display
+
+instance GhcPkg.BinaryStringRep String where
+  fromStringRep = fromUTF8 . BS.unpack
+  toStringRep   = BS.pack . toUTF8
+
+instance GhcPkg.BinaryStringRep UnitId where
+  fromStringRep = fromMaybe (error "BinaryStringRep UnitId")
+                . simpleParse . fromStringRep
+  toStringRep   = toStringRep . display
+
+instance GhcPkg.DbUnitIdModuleRep ComponentId OpenUnitId ModuleName OpenModule where
+  fromDbModule (GhcPkg.DbModule uid mod_name) = OpenModule uid mod_name
+  fromDbModule (GhcPkg.DbModuleVar mod_name) = OpenModuleVar mod_name
+  toDbModule (OpenModule uid mod_name) = GhcPkg.DbModule uid mod_name
+  toDbModule (OpenModuleVar mod_name) = GhcPkg.DbModuleVar mod_name
+  fromDbUnitId (GhcPkg.DbUnitId cid insts) = IndefFullUnitId cid (Map.fromList insts)
+  fromDbUnitId (GhcPkg.DbHashedUnitId cid bs) = DefiniteUnitId (DefUnitId (UnitId cid (fmap fromStringRep bs)))
+  toDbUnitId (IndefFullUnitId cid insts) = GhcPkg.DbUnitId cid (Map.toList insts)
+  toDbUnitId (DefiniteUnitId (DefUnitId (UnitId cid mb_hash))) = GhcPkg.DbHashedUnitId cid (fmap toStringRep mb_hash)
 
 -- -----------------------------------------------------------------------------
 -- Exposing, Hiding, Trusting, Distrusting, Unregistering are all similar
 
-exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
+exposePackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO ()
 exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True})
 
-hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
+hidePackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO ()
 hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False})
 
-trustPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
+trustPackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO ()
 trustPackage = modifyPackage (\p -> ModifyPackage p{trusted=True})
 
-distrustPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
+distrustPackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO ()
 distrustPackage = modifyPackage (\p -> ModifyPackage p{trusted=False})
 
-unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
+unregisterPackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO ()
 unregisterPackage = modifyPackage RemovePackage
 
 modifyPackage
   :: (InstalledPackageInfo -> DBOp)
-  -> PackageIdentifier
+  -> PackageArg
   -> Verbosity
   -> [Flag]
   -> Force
   -> IO ()
-modifyPackage fn pkgid verbosity my_flags force = do
+modifyPackage fn pkgarg verbosity my_flags force = do
   (db_stack, Just _to_modify, flag_dbs) <-
-      getPkgDatabases verbosity True{-modify-} True{-use cache-} False{-expand vars-} my_flags
+      getPkgDatabases verbosity True{-modify-} True{-use user-}
+                                True{-use cache-} False{-expand vars-} my_flags
 
   -- Do the search for the package respecting flags...
-  (db, ps) <- fmap head $ findPackagesByDB flag_dbs (Id pkgid)
-  let 
+  (db, ps) <- fmap head $ findPackagesByDB flag_dbs pkgarg
+  let
       db_name = location db
       pkgs    = packages db
 
-      pids = map sourcePackageId ps
+      pks = map installedUnitId ps
 
-      cmds = [ fn pkg | pkg <- pkgs, sourcePackageId pkg `elem` pids ]
+      cmds = [ fn pkg | pkg <- pkgs, installedUnitId pkg `elem` pks ]
       new_db = updateInternalDB db cmds
 
       -- ...but do consistency checks with regards to the full stack
       old_broken = brokenPackages (allPackagesInStack db_stack)
       rest_of_stack = filter ((/= db_name) . location) db_stack
       new_stack = new_db : rest_of_stack
-      new_broken = map sourcePackageId (brokenPackages (allPackagesInStack new_stack))
-      newly_broken = filter (`notElem` map sourcePackageId old_broken) new_broken
+      new_broken = brokenPackages (allPackagesInStack new_stack)
+      newly_broken = filter ((`notElem` map installedUnitId old_broken)
+                            . installedUnitId) new_broken
   --
+  let displayQualPkgId pkg
+        | [_] <- filter ((== pkgid) . sourcePackageId)
+                        (allPackagesInStack db_stack)
+            = display pkgid
+        | otherwise = display pkgid ++ "@" ++ display (installedUnitId pkg)
+        where pkgid = sourcePackageId pkg
   when (not (null newly_broken)) $
-      dieOrForceAll force ("unregistering " ++ display pkgid ++
-           " would break the following packages: "
-              ++ unwords (map display newly_broken))
+      dieOrForceAll force ("unregistering would break the following packages: "
+              ++ unwords (map displayQualPkgId newly_broken))
 
   changeDB verbosity cmds db
 
 recache :: Verbosity -> [Flag] -> IO ()
 recache verbosity my_flags = do
-  (db_stack, Just to_modify, _flag_dbs) <- 
-     getPkgDatabases verbosity True{-modify-} False{-no cache-} False{-expand vars-} my_flags
+  (db_stack, Just to_modify, _flag_dbs) <-
+     getPkgDatabases verbosity True{-modify-} True{-use user-} False{-no cache-}
+                               False{-expand vars-} my_flags
   let
         db_to_operate_on = my_head "recache" $
                            filter ((== to_modify).location) db_stack
@@ -1074,8 +1240,9 @@ listPackages ::  Verbosity -> [Flag] -> Maybe PackageArg
              -> IO ()
 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-} False{-expand vars-} my_flags
+  (db_stack, _, flag_db_stack) <-
+     getPkgDatabases verbosity False{-modify-} False{-use user-}
+                               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 =
@@ -1094,7 +1261,10 @@ listPackages verbosity my_flags mPackageName mModuleName = do
                    case pkgName p1 `compare` pkgName p2 of
                         LT -> LT
                         GT -> GT
-                        EQ -> pkgVersion p1 `compare` pkgVersion p2
+                        EQ -> case pkgVersion p1 `compare` pkgVersion p2 of
+                                LT -> LT
+                                GT -> GT
+                                EQ -> installedUnitId pkg1 `compare` installedUnitId pkg2
                    where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2)
 
       stack = reverse db_stack_sorted
@@ -1102,24 +1272,21 @@ listPackages verbosity my_flags mPackageName mModuleName = do
       match `exposedInPkg` pkg = any match (map display $ exposedModules pkg)
 
       pkg_map = allPackagesInStack db_stack
-      broken = map sourcePackageId (brokenPackages pkg_map)
+      broken = map installedUnitId (brokenPackages pkg_map)
 
       show_normal PackageDB{ location = db_name, packages = pkg_confs } =
-          do hPutStrLn stdout (db_name ++ ":")
-             if null pp_pkgs
+          do hPutStrLn stdout db_name
+             if null pkg_confs
                  then hPutStrLn stdout "    (no packages)"
-                 else hPutStrLn stdout $ unlines (map ("    " ++) pp_pkgs)
+                 else hPutStrLn stdout $ unlines (map ("    " ++) (map pp_pkg pkg_confs))
            where
-                 -- Sort using instance Ord PackageId
-                 pp_pkgs = map pp_pkg . sortBy (comparing installedPackageId) $ pkg_confs
                  pp_pkg p
-                   | sourcePackageId p `elem` broken = printf "{%s}" doc
+                   | installedUnitId p `elem` broken = printf "{%s}" doc
                    | exposed p = doc
                    | otherwise = printf "(%s)" doc
-                   where doc | verbosity >= Verbose = printf "%s (%s)" pkg ipid
+                   where doc | verbosity >= Verbose = printf "%s (%s)" pkg (display (installedUnitId p))
                              | otherwise            = pkg
                           where
-                          InstalledPackageId ipid = installedPackageId p
                           pkg = display (sourcePackageId p)
 
       show_simple = simplePackageList my_flags . allPackagesInStack
@@ -1134,21 +1301,23 @@ listPackages verbosity my_flags mPackageName mModuleName = do
     mapM_ show_normal stack
 #else
     let
-       show_colour withF db =
-           mconcat $ map (<#> termText "\n") $
-               (termText (location db) :
-                  map (termText "   " <#>) (map pp_pkg (packages db)))
+       show_colour withF db@PackageDB{ packages = pkg_confs } =
+           if null pkg_confs
+           then termText (location db) <#> termText "\n    (no packages)\n"
+           else
+               mconcat $ map (<#> termText "\n") $
+                           (termText (location db)
+                            : map (termText "    " <#>) (map pp_pkg pkg_confs))
           where
                    pp_pkg p
-                     | sourcePackageId p `elem` broken = withF Red  doc
+                     | installedUnitId p `elem` broken = withF Red  doc
                      | exposed p                       = doc
                      | otherwise                       = withF Blue doc
                      where doc | verbosity >= Verbose
-                               = termText (printf "%s (%s)" pkg ipid)
+                               = termText (printf "%s (%s)" pkg (display (installedUnitId p)))
                                | otherwise
                                = termText pkg
                             where
-                            InstalledPackageId ipid = installedPackageId p
                             pkg = display (sourcePackageId p)
 
     is_tty <- hIsTerminalDevice stdout
@@ -1165,15 +1334,15 @@ simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
 simplePackageList my_flags pkgs = do
    let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
                                                   else display
-       -- Sort using instance Ord PackageId
-       strs = map showPkg $ sort $ map sourcePackageId pkgs
+       strs = map showPkg $ map sourcePackageId pkgs
    when (not (null pkgs)) $
       hPutStrLn stdout $ concat $ intersperse " " strs
 
 showPackageDot :: Verbosity -> [Flag] -> IO ()
 showPackageDot verbosity myflags = do
-  (_, _, flag_db_stack) <- 
-      getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} myflags
+  (_, _, flag_db_stack) <-
+      getPkgDatabases verbosity False{-modify-} False{-use user-}
+                                True{-use cache-} False{-expand vars-} myflags
 
   let all_pkgs = allPackagesInStack flag_db_stack
       ipix  = PackageIndex.fromList all_pkgs
@@ -1183,8 +1352,8 @@ showPackageDot verbosity myflags = do
   mapM_ putStrLn [ quote from ++ " -> " ++ quote to
                  | p <- all_pkgs,
                    let from = display (sourcePackageId p),
-                   depid <- depends p,
-                   Just dep <- [PackageIndex.lookupInstalledPackageId ipix depid],
+                   key <- depends p,
+                   Just dep <- [PackageIndex.lookupUnitId ipix key],
                    let to = display (sourcePackageId dep)
                  ]
   putStrLn "}"
@@ -1192,10 +1361,13 @@ showPackageDot verbosity myflags = do
 -- -----------------------------------------------------------------------------
 -- Prints the highest (hidden or exposed) version of a package
 
-latestPackage ::  Verbosity -> [Flag] -> PackageIdentifier -> IO ()
+-- ToDo: This is no longer well-defined with unit ids, because the
+-- dependencies may be varying versions
+latestPackage ::  Verbosity -> [Flag] -> GlobPackageIdentifier -> IO ()
 latestPackage verbosity my_flags pkgid = do
-  (_, _, flag_db_stack) <- 
-     getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags
+  (_, _, flag_db_stack) <-
+     getPkgDatabases verbosity False{-modify-} False{-use user-}
+                               True{-use cache-} False{-expand vars-} my_flags
 
   ps <- findPackages flag_db_stack (Id pkgid)
   case ps of
@@ -1209,16 +1381,18 @@ latestPackage verbosity my_flags pkgid = do
 
 describePackage :: Verbosity -> [Flag] -> PackageArg -> Bool -> IO ()
 describePackage verbosity my_flags pkgarg expand_pkgroot = do
-  (_, _, flag_db_stack) <- 
-      getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
+  (_, _, flag_db_stack) <-
+      getPkgDatabases verbosity False{-modify-} False{-use user-}
+                                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] -> Bool -> IO ()
 dumpPackages verbosity my_flags expand_pkgroot = do
-  (_, _, flag_db_stack) <- 
-     getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
+  (_, _, flag_db_stack) <-
+     getPkgDatabases verbosity False{-modify-} False{-use user-}
+                               True{-use cache-} expand_pkgroot my_flags
   doDump expand_pkgroot [ (pkg, locationAbsolute db)
                         | db <- flag_db_stack, pkg <- packages db ]
 
@@ -1250,20 +1424,20 @@ findPackagesByDB db_stack pkgarg
         [] -> die ("cannot find package " ++ pkg_msg pkgarg)
         ps -> return ps
   where
-        pkg_msg (Id pkgid)           = display pkgid
+        pkg_msg (Id pkgid)           = displayGlobPkgId pkgid
+        pkg_msg (IUId ipid)          = display ipid
         pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
 
-matches :: PackageIdentifier -> PackageIdentifier -> Bool
-pid `matches` pid'
-  = (pkgName pid == pkgName pid')
-    && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
-
-realVersion :: PackageIdentifier -> Bool
-realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
-  -- when versionBranch == [], this is a glob
+matches :: GlobPackageIdentifier -> PackageIdentifier -> Bool
+GlobPackageIdentifier pn `matches` pid'
+  = (pn == pkgName pid')
+ExactPackageIdentifier pid `matches` pid'
+  = pkgName pid == pkgName pid' &&
+    (pkgVersion pid == pkgVersion pid' || pkgVersion pid == nullVersion)
 
 matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
 (Id pid)        `matchesPkg` pkg = pid `matches` sourcePackageId pkg
+(IUId ipid)     `matchesPkg` pkg = ipid == installedUnitId pkg
 (Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg))
 
 -- -----------------------------------------------------------------------------
@@ -1271,8 +1445,9 @@ matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
 
 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-} expand_pkgroot my_flags
+  (_, _, flag_db_stack) <-
+      getPkgDatabases verbosity False{-modify-} False{-use user-}
+                                True{-use cache-} expand_pkgroot my_flags
   fns <- mapM toField fields
   ps <- findPackages flag_db_stack pkgarg
   mapM_ (selectFields fns) ps
@@ -1290,10 +1465,12 @@ describeField verbosity my_flags pkgarg fields expand_pkgroot = do
 
 checkConsistency :: Verbosity -> [Flag] -> IO ()
 checkConsistency verbosity my_flags = do
-  (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.
+  (db_stack, _, _) <-
+         getPkgDatabases verbosity False{-modify-} True{-use user-}
+                                   True{-use cache-} True{-expand vars-}
+                                   my_flags
+         -- although check is not a modify command, we do need to use the user
+         -- db, because we may need it to verify package deps.
 
   let simple_output = FlagSimpleOutput `elem` my_flags
 
@@ -1301,16 +1478,16 @@ checkConsistency verbosity my_flags = do
 
       checkPackage p = do
          (_,es,ws) <- runValidate $ checkPackageConfig p verbosity db_stack
-                                                       False True True
+                                                       True True
          if null es
             then do when (not simple_output) $ do
-                      _ <- reportValidateErrors [] ws "" Nothing
+                      _ <- reportValidateErrors verbosity [] ws "" Nothing
                       return ()
                     return []
             else do
               when (not simple_output) $ do
                   reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":")
-                  _ <- reportValidateErrors es ws "  " Nothing
+                  _ <- reportValidateErrors verbosity es ws "  " Nothing
                   return ()
               return [p]
 
@@ -1348,7 +1525,7 @@ closure pkgs db_stack = go pkgs db_stack
                  -> Bool
    depsAvailable pkgs_ok pkg = null dangling
         where dangling = filter (`notElem` pids) (depends pkg)
-              pids = map installedPackageId pkgs_ok
+              pids = map installedUnitId pkgs_ok
 
         -- we want mutually recursive groups of package to show up
         -- as broken. (#1750)
@@ -1356,46 +1533,6 @@ closure pkgs db_stack = go pkgs db_stack
 brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
 brokenPackages pkgs = snd (closure [] pkgs)
 
--- -----------------------------------------------------------------------------
--- Manipulating package.conf files
-
-type InstalledPackageInfoString = InstalledPackageInfo_ String
-
-convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString
-convertPackageInfoOut
-    (pkgconf@(InstalledPackageInfo { exposedModules = e,
-                                     reexportedModules = r,
-                                     hiddenModules = h })) =
-        pkgconf{ exposedModules = map display e,
-                 reexportedModules = map (fmap display) r,
-                 hiddenModules  = map display h }
-
-convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo
-convertPackageInfoIn
-    (pkgconf@(InstalledPackageInfo { exposedModules = e,
-                                     reexportedModules = r,
-                                     hiddenModules = h })) =
-        pkgconf{ exposedModules = map convert e,
-                 reexportedModules = map (fmap convert) r,
-                 hiddenModules  = map convert h }
-    where convert = fromJust . simpleParse
-
-writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO ()
-writeNewConfig verbosity filename ipis = do
-  when (verbosity >= Normal) $
-      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
-    `catchIO` \e ->
-      if isPermissionError e
-      then die (filename ++ ": you don't have permission to modify this file")
-      else ioError e
-  when (verbosity >= Normal) $
-      infoLn "done."
-
 -----------------------------------------------------------------------------
 -- Sanity-check a new package config, and automatically build GHCi libs
 -- if requested.
@@ -1409,11 +1546,10 @@ instance Functor Validate where
     fmap = liftM
 
 instance Applicative Validate where
-    pure = return
+    pure a = V $ pure (a, [], [])
     (<*>) = ap
 
 instance Monad Validate where
-   return a = V $ return (a, [], [])
    m >>= k = V $ do
       (a, es, ws) <- runValidate m
       (b, es', ws') <- runValidate (k a)
@@ -1429,9 +1565,9 @@ liftIO :: IO a -> Validate a
 liftIO k = V (k >>= \a -> return (a,[],[]))
 
 -- returns False if we should die
-reportValidateErrors :: [ValidateError] -> [ValidateWarning]
+reportValidateErrors :: Verbosity -> [ValidateError] -> [ValidateWarning]
                      -> String -> Maybe Force -> IO Bool
-reportValidateErrors es ws prefix mb_force = do
+reportValidateErrors verbosity es ws prefix mb_force = do
   mapM_ (warn . (prefix++)) ws
   oks <- mapM report es
   return (and oks)
@@ -1439,7 +1575,8 @@ reportValidateErrors es ws prefix mb_force = do
     report (f,s)
       | Just force <- mb_force
       = if (force >= f)
-           then do reportError (prefix ++ s ++ " (ignoring)")
+           then do when (verbosity >= Normal) $
+                        reportError (prefix ++ s ++ " (ignoring)")
                    return True
            else if f < CannotForce
                    then do reportError (prefix ++ s ++ " (use --force to override)")
@@ -1454,30 +1591,29 @@ reportValidateErrors es ws prefix mb_force = do
 validatePackageConfig :: InstalledPackageInfo
                       -> Verbosity
                       -> PackageDBStack
-                      -> Bool   -- auto-ghc-libs
                       -> Bool   -- multi_instance
                       -> Bool   -- update, or check
                       -> Force
                       -> IO ()
-validatePackageConfig pkg verbosity db_stack auto_ghci_libs
+validatePackageConfig pkg verbosity db_stack
                       multi_instance update force = do
   (_,es,ws) <- runValidate $
                  checkPackageConfig pkg verbosity db_stack
-                                    auto_ghci_libs multi_instance update
-  ok <- reportValidateErrors es ws (display (sourcePackageId pkg) ++ ": ") (Just force)
+                                    multi_instance update
+  ok <- reportValidateErrors verbosity es ws
+          (display (sourcePackageId pkg) ++ ": ") (Just force)
   when (not ok) $ exitWith (ExitFailure 1)
 
 checkPackageConfig :: InstalledPackageInfo
                       -> Verbosity
                       -> PackageDBStack
-                      -> Bool   -- auto-ghc-libs
                       -> Bool   -- multi_instance
                       -> Bool   -- update, or check
                       -> Validate ()
-checkPackageConfig pkg verbosity db_stack auto_ghci_libs
+checkPackageConfig pkg verbosity db_stack
                    multi_instance update = do
-  checkInstalledPackageId pkg db_stack update
   checkPackageId pkg
+  checkUnitId pkg db_stack update
   checkDuplicates db_stack pkg multi_instance update
   mapM_ (checkDep db_stack) (depends pkg)
   checkDuplicateDepends (depends pkg)
@@ -1487,24 +1623,15 @@ checkPackageConfig pkg verbosity db_stack auto_ghci_libs
   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 verbosity (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
+  checkDuplicateModules pkg
+  checkExposedModules db_stack pkg
+  checkOtherModules pkg
+  let has_code = Set.null (openModuleSubstFreeHoles (Map.fromList (instantiatedWith pkg)))
+  when has_code $ mapM_ (checkHSLib verbosity (libraryDirs pkg)) (hsLibraries pkg)
   -- ToDo: check these somehow?
   --    extra_libraries :: [String],
   --    c_includes      :: [String],
 
-checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool 
-                        -> Validate ()
-checkInstalledPackageId ipi db_stack update = do
-  let ipid@(InstalledPackageId str) = installedPackageId ipi
-  when (null str) $ verror CannotForce "missing id field"
-  let dups = [ p | p <- allPackagesInStack db_stack, 
-                   installedPackageId p == ipid ]
-  when (not update && not (null dups)) $
-    verror CannotForce $
-        "package(s) with this id already exist: " ++ 
-         unwords (map (display.packageId) dups)
-
 -- When the package name and version are put together, sometimes we can
 -- end up with a package id that cannot be parsed.  This will lead to
 -- difficulties when the user wants to refer to the package later, so
@@ -1517,6 +1644,21 @@ checkPackageId ipi =
     []  -> verror CannotForce ("invalid package identifier: " ++ str)
     _   -> verror CannotForce ("ambiguous package identifier: " ++ str)
 
+checkUnitId :: InstalledPackageInfo -> PackageDBStack -> Bool
+                -> Validate ()
+checkUnitId ipi db_stack update = do
+  let uid = installedUnitId ipi
+  when (null (display uid)) $ verror CannotForce "missing id field"
+  when (display uid /= compatPackageKey ipi) $
+    verror CannotForce $ "installed package info from too old version of Cabal "
+                      ++ "(key field does not match id field)"
+  let dups = [ p | p <- allPackagesInStack db_stack,
+                   installedUnitId p == uid ]
+  when (not update && not (null dups)) $
+    verror CannotForce $
+        "package(s) with this id already exist: " ++
+         unwords (map (display.installedUnitId) dups)
+
 checkDuplicates :: PackageDBStack -> InstalledPackageInfo
                 -> Bool -> Bool-> Validate ()
 checkDuplicates db_stack pkg multi_instance update = do
@@ -1535,7 +1677,8 @@ checkDuplicates db_stack pkg multi_instance update = do
         uncasep = map toLower . display
         dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs)
 
-  when (not update && not (null dups)) $ verror ForceAll $
+  when (not update && not multi_instance
+                   && not (null dups)) $ verror ForceAll $
         "Package names may be treated case-insensitively in the future.\n"++
         "Package " ++ display pkgid ++
         " overlaps with: " ++ unwords (map display dups)
@@ -1569,20 +1712,20 @@ checkPath url_ok is_dir warn_only thisfield d
        let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a "
                                         ++ if is_dir then "directory" else "file"
        in
-       if warn_only 
+       if warn_only
           then vwarn msg
           else verror ForceFiles msg
 
-checkDep :: PackageDBStack -> InstalledPackageId -> Validate ()
+checkDep :: PackageDBStack -> UnitId -> Validate ()
 checkDep db_stack pkgid
   | pkgid `elem` pkgids = return ()
   | otherwise = verror ForceAll ("dependency \"" ++ display pkgid
                                  ++ "\" doesn't exist")
   where
         all_pkgs = allPackagesInStack db_stack
-        pkgids = map installedPackageId all_pkgs
+        pkgids = map installedUnitId all_pkgs
 
-checkDuplicateDepends :: [InstalledPackageId] -> Validate ()
+checkDuplicateDepends :: [UnitId] -> Validate ()
 checkDuplicateDepends deps
   | null dups = return ()
   | otherwise = verror ForceAll ("package has duplicate dependencies: " ++
@@ -1590,108 +1733,128 @@ checkDuplicateDepends deps
   where
        dups = [ p | (p:_:_) <- group (sort deps) ]
 
-checkHSLib :: Verbosity -> [String] -> Bool -> String -> Validate ()
-checkHSLib verbosity dirs auto_ghci_libs lib = do
-  let batch_lib_file = "lib" ++ lib ++ ".a"
-      filenames = ["lib" ++ lib ++ ".a",
+checkHSLib :: Verbosity -> [String] -> String -> Validate ()
+checkHSLib _verbosity dirs lib = do
+  let filenames = ["lib" ++ lib ++ ".a",
                    "lib" ++ lib ++ ".p_a",
                    "lib" ++ lib ++ "-ghc" ++ Version.version ++ ".so",
                    "lib" ++ lib ++ "-ghc" ++ Version.version ++ ".dylib",
                             lib ++ "-ghc" ++ Version.version ++ ".dll"]
-  m <- liftIO $ doesFileExistOnPath filenames dirs
-  case m of
-    Nothing -> verror ForceFiles ("cannot find any of " ++ show filenames ++
-                                  " on library path")
-    Just dir -> liftIO $ checkGHCiLib verbosity dir batch_lib_file lib auto_ghci_libs
-
-doesFileExistOnPath :: [FilePath] -> [FilePath] -> IO (Maybe FilePath)
-doesFileExistOnPath filenames paths = go fullFilenames
-  where fullFilenames = [ (path, path </> filename)
+  b <- liftIO $ doesFileExistOnPath filenames dirs
+  when (not b) $
+    verror ForceFiles ("cannot find any of " ++ show filenames ++
+                       " on library path")
+
+doesFileExistOnPath :: [FilePath] -> [FilePath] -> IO Bool
+doesFileExistOnPath filenames paths = anyM doesFileExist fullFilenames
+  where fullFilenames = [ path </> filename
                         | filename <- filenames
                         , path <- paths ]
-        go []             = return Nothing
-        go ((p, fp) : xs) = do b <- doesFileExist fp
-                               if b then return (Just p) else go xs
-
--- XXX maybe should check reexportedModules too
-checkModules :: InstalledPackageInfo -> Validate ()
-checkModules pkg = do
-  mapM_ findModule (exposedModules pkg ++ hiddenModules pkg)
+
+-- | Perform validation checks (module file existence checks) on the
+-- @hidden-modules@ field.
+checkOtherModules :: InstalledPackageInfo -> Validate ()
+checkOtherModules pkg = mapM_ (checkModuleFile pkg) (hiddenModules pkg)
+
+-- | Perform validation checks (module file existence checks and module
+-- reexport checks) on the @exposed-modules@ field.
+checkExposedModules :: PackageDBStack -> InstalledPackageInfo -> Validate ()
+checkExposedModules db_stack pkg =
+  mapM_ checkExposedModule (exposedModules pkg)
   where
-    findModule modl =
+    checkExposedModule (ExposedModule modl reexport) = do
+      let checkOriginal = checkModuleFile pkg modl
+          checkReexport = checkModule "module reexport" db_stack pkg
+      maybe checkOriginal checkReexport reexport
+
+-- | Validates the existence of an appropriate @hi@ file associated with
+-- a module.  Used for both @hidden-modules@ and @exposed-modules@ which
+-- are not reexports.
+checkModuleFile :: InstalledPackageInfo -> ModuleName -> Validate ()
+checkModuleFile pkg modl =
       -- there's no interface file for GHC.Prim
-      unless (modl == fromString "GHC.Prim") $ do
-      let files = [ toFilePath modl <.> extension
+      unless (modl == ModuleName.fromString "GHC.Prim") $ do
+      let files = [ ModuleName.toFilePath modl <.> extension
                   | extension <- ["hi", "p_hi", "dyn_hi" ] ]
-      m <- liftIO $ doesFileExistOnPath files (importDirs pkg)
-      when (isNothing m) $
+      b <- liftIO $ doesFileExistOnPath files (importDirs pkg)
+      when (not b) $
          verror ForceFiles ("cannot find any of " ++ show files)
 
-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 :: 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
-  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)
-  execDir <- getLibDir
-  r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
-#else
-  r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
-#endif
-  when (r /= ExitSuccess) $ exitWith r
-  when (verbosity >= Normal) $
-    infoLn (" done.")
-
--- -----------------------------------------------------------------------------
--- Searching for modules
-
-#if not_yet
-
-findModules :: [FilePath] -> IO [String]
-findModules paths =
-  mms <- mapM searchDir paths
-  return (concat mms)
-
-searchDir path prefix = do
-  fs <- getDirectoryEntries path `catchIO` \_ -> return []
-  searchEntries path prefix fs
-
-searchEntries path prefix [] = return []
-searchEntries path prefix (f:fs)
-  | looks_like_a_module  =  do
-        ms <- searchEntries path prefix fs
-        return (prefix `joinModule` f : ms)
-  | looks_like_a_component  =  do
-        ms <- searchDir (path </> f) (prefix `joinModule` f)
-        ms' <- searchEntries path prefix fs
-        return (ms ++ ms')
-  | otherwise
-        searchEntries path prefix fs
-
+-- | Validates that @exposed-modules@ and @hidden-modules@ do not have duplicate
+-- entries.
+-- ToDo: this needs updating for signatures: signatures can validly show up
+-- multiple times in the @exposed-modules@ list as long as their backing
+-- implementations agree.
+checkDuplicateModules :: InstalledPackageInfo -> Validate ()
+checkDuplicateModules pkg
+  | null dups = return ()
+  | otherwise = verror ForceAll ("package has duplicate modules: " ++
+                                     unwords (map display dups))
+  where
+    dups = [ m | (m:_:_) <- group (sort mods) ]
+    mods = map exposedName (exposedModules pkg) ++ hiddenModules pkg
+
+-- | Validates an original module entry, either the origin of a module reexport
+-- or the backing implementation of a signature, by checking that it exists,
+-- really is an original definition, and is accessible from the dependencies of
+-- the package.
+-- ToDo: If the original module in question is a backing signature
+-- implementation, then we should also check that the original module in
+-- question is NOT a signature (however, if it is a reexport, then it's fine
+-- for the original module to be a signature.)
+checkModule :: String
+            -> PackageDBStack
+            -> InstalledPackageInfo
+            -> OpenModule
+            -> Validate ()
+checkModule _ _ _ (OpenModuleVar _) = error "Impermissible reexport"
+checkModule field_name db_stack pkg
+    (OpenModule (DefiniteUnitId (DefUnitId definingPkgId)) definingModule) =
+  let mpkg = if definingPkgId == installedUnitId pkg
+              then Just pkg
+              else PackageIndex.lookupUnitId ipix definingPkgId
+  in case mpkg of
+      Nothing
+           -> verror ForceAll (field_name ++ " refers to a non-existent " ++
+                               "defining package: " ++
+                                       display definingPkgId)
+
+      Just definingPkg
+        | not (isIndirectDependency definingPkgId)
+           -> verror ForceAll (field_name ++ " refers to a defining " ++
+                               "package that is not a direct (or indirect) " ++
+                               "dependency of this package: " ++
+                                       display definingPkgId)
+
+        | otherwise
+        -> case find ((==definingModule).exposedName)
+                     (exposedModules definingPkg) of
+            Nothing ->
+              verror ForceAll (field_name ++ " refers to a module " ++
+                               display definingModule ++ " " ++
+                               "that is not exposed in the " ++
+                               "defining package " ++ display definingPkgId)
+            Just (ExposedModule {exposedReexport = Just _} ) ->
+              verror ForceAll (field_name ++ " refers to a module " ++
+                               display definingModule ++ " " ++
+                               "that is reexported but not defined in the " ++
+                               "defining package " ++ display definingPkgId)
+            _ -> return ()
   where
-        (base,suffix) = splitFileExt f
-        looks_like_a_module =
-                suffix `elem` haskell_suffixes &&
-                all okInModuleName base
-        looks_like_a_component =
-                null suffix && all okInModuleName base
+    all_pkgs = allPackagesInStack db_stack
+    ipix     = PackageIndex.fromList all_pkgs
 
-okInModuleName c
+    isIndirectDependency pkgid = fromMaybe False $ do
+      thispkg  <- graphVertex (installedUnitId pkg)
+      otherpkg <- graphVertex pkgid
+      return (Graph.path depgraph thispkg otherpkg)
+    (depgraph, _, graphVertex) =
+      PackageIndex.dependencyGraph (PackageIndex.insert pkg ipix)
+
+checkModule _ _ _ (OpenModule (IndefFullUnitId _ _) _) =
+    -- TODO: add some checks here
+    return ()
 
-#endif
 
 -- ---------------------------------------------------------------------------
 -- expanding environment variables in the package configuration
@@ -1831,104 +1994,54 @@ installSignalHandlers = do
   return ()
 #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
 
-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 =
-  withFileAtomic targetFile $ \h -> do
-     hSetBinaryMode h True
-     B.hPutStr h (Bin.encode obj)
-
-writeFileUtf8Atomic :: FilePath -> String -> IO ()
-writeFileUtf8Atomic targetFile content =
-  withFileAtomic targetFile $ \h -> do
-     hSetEncoding h utf8
-     hPutStr h content
-
--- copied from Cabal's Distribution.Simple.Utils, except that we want
--- to use text files here, rather than binary files.
-withFileAtomic :: FilePath -> (Handle -> IO ()) -> IO ()
-withFileAtomic targetFile write_content = do
-  (newFile, newHandle) <- openNewFile targetDir template
-  do  write_content newHandle
-      hClose newHandle
-#if mingw32_HOST_OS || mingw32_TARGET_OS
-      renameFile newFile targetFile
-        -- If the targetFile exists then renameFile will fail
-        `catchIO` \err -> do
-          exists <- doesFileExist targetFile
-          if exists
-            then do removeFileSafe targetFile
-                    -- Big fat hairy race condition
-                    renameFile newFile targetFile
-                    -- If the removeFile succeeds and the renameFile fails
-                    -- then we've lost the atomic property.
-            else throwIOIO err
-#else
-      renameFile newFile targetFile
-#endif
-   `Exception.onException` do hClose newHandle
-                              removeFileSafe newFile
-  where
-    template = targetName <.> "tmp"
-    targetDir | null targetDir_ = "."
-              | otherwise       = targetDir_
-    --TODO: remove this when takeDirectory/splitFileName is fixed
-    --      to always return a valid dir
-    (targetDir_,targetName) = splitFileName targetFile
-
-openNewFile :: FilePath -> String -> IO (FilePath, Handle)
-openNewFile dir template = do
-  -- 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
-
--- | The function splits the given string to substrings
--- using 'isSearchPathSeparator'.
-parseSearchPath :: String -> [FilePath]
-parseSearchPath path = split path
-  where
-    split :: String -> [String]
-    split s =
-      case rest' of
-        []     -> [chunk]
-        _:rest -> chunk : split rest
-      where
-        chunk =
-          case chunk' of
-#ifdef mingw32_HOST_OS
-            ('\"':xs@(_:_)) | last xs == '\"' -> init xs
-#endif
-            _                                 -> chunk'
-
-        (chunk', rest') = break isSearchPathSeparator s
-
-readUTF8File :: FilePath -> IO String
-readUTF8File file = do
-  h <- openFile file ReadMode
-  -- fix the encoding to UTF-8
-  hSetEncoding h utf8
-  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
 
+-- | Turn a path relative to the current directory into a (normalised)
+-- absolute path.
 absolutePath :: FilePath -> IO FilePath
 absolutePath path = return . normalise . (</> path) =<< getCurrentDirectory
+
+
+{- Note [writeAtomic leaky abstraction]
+GhcPkg.writePackageDb calls writeAtomic, which first writes to a temp file,
+and then moves the tempfile to its final destination. This all happens in the
+same directory (package.conf.d).
+Moving a file doesn't change its modification time, but it *does* change the
+modification time of the directory it is placed in. Since we compare the
+modification time of the cache file to that of the directory it is in to
+decide whether the cache is out-of-date, it will be instantly out-of-date
+after creation, if the renaming takes longer than the smallest time difference
+that the getModificationTime can measure.
+
+The solution we opt for is a "touch" of the cache file right after it is
+created. This resets the modification time of the cache file and the directory
+to the current time.
+
+Other possible solutions:
+  * backdate the modification time of the directory to the modification time
+    of the cachefile. This is what we used to do on posix platforms. An
+    observer of the directory would see the modification time of the directory
+    jump back in time. Not nice, although in practice probably not a problem.
+    Also note that a cross-platform implementation of setModificationTime is
+    currently not available.
+  * set the modification time of the cache file to the modification time of
+    the directory (instead of the curent time). This could also work,
+    given that we are the only ones writing to this directory. It would also
+    require a high-precision getModificationTime (lower precision times get
+    rounded down it seems), or the cache would still be out-of-date.
+  * change writeAtomic to create the tempfile outside of the target file's
+    directory.
+  * create the cachefile outside of the package.conf.d directory in the first
+    place. But there are tests and there might be tools that currently rely on
+    the package.conf.d/package.cache format.
+-}