Registering packages needs all the package dbs listed

Important for the case of registering inplace when we're using a
specific package db, e.g. when doing isolated builds.

Distribution/Simple/Build.hs

@@ -123,7 +123,8 @@ build pkg_descr lbi flags suffixes = do
     -- Register the library in-place, so exes can depend
     -- on internally defined libraries.
     registerPackage verbosity
-      installedPkgInfo pkg_descr lbi True{-inplace-} internalPackageDB
+      installedPkgInfo pkg_descr lbi True -- True meaning inplace
+      (withPackageDB lbi ++ [internalPackageDB])
 
   -- Use the internal package db for the exes.
   let lbi' = lbi { withPackageDB = withPackageDB lbi ++ [internalPackageDB] }

Distribution/Simple/Compiler.hs

@@ -105,7 +105,7 @@ compilerVersion = (\(CompilerId _ v) -> v) . compilerId
 data PackageDB = GlobalPackageDB
                | UserPackageDB
                | SpecificPackageDB FilePath
-    deriving (Eq, Show, Read)
+    deriving (Eq, Ord, Show, Read)
 
 -- | We typically get packages from several databases, and stack them
 -- together. This type lets us be explicit about that stacking. For example

Distribution/Simple/GHC.hs

@@ -66,7 +66,8 @@ module Distribution.Simple.GHC (
         installLib, installExe,
         libAbiHash,
         ghcOptions,
-        ghcVerbosityOptions
+        ghcVerbosityOptions,
+        ghcPackageDbOptions,
  ) where
 
 import qualified Distribution.Simple.GHC.IPI641 as IPI641
@@ -795,15 +796,14 @@ ghcPackageFlags lbi clbi
 
 ghcPackageDbOptions :: PackageDBStack -> [String]
 ghcPackageDbOptions dbstack = case dbstack of
-  (GlobalPackageDB:dbs)
-    | UserPackageDB `elem` dbs -> concatMap specific dbs
-    | otherwise                -> "-no-user-package-conf"
-                                : concatMap specific dbs
-  _                            -> ierror
- where
+  (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs
+  (GlobalPackageDB:dbs)               -> "-no-user-package-conf"
+                                       : concatMap specific dbs
+  _                                   -> ierror
+  where
     specific (SpecificPackageDB db) = [ "-package-conf", db ]
-    specific _                      = []
-    ierror = error "internal error: unexpected package db stack"
+    specific _ = ierror
+    ierror     = error "internal error: unexpected package db stack"
 
 constructCcCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo
                    -> FilePath -> FilePath -> Verbosity -> Bool

Distribution/Simple/Program/HcPkg.hs

@@ -34,7 +34,7 @@ import Distribution.InstalledPackageInfo
 import Distribution.ParseUtils
          ( ParseResult(..) )
 import Distribution.Simple.Compiler
-         ( PackageDB(..) )
+         ( PackageDB(..), PackageDBStack )
 import Distribution.Simple.Program.Types
          ( ConfiguredProgram(programId, programVersion) )
 import Distribution.Simple.Program.Run
@@ -58,7 +58,7 @@ import Control.Monad
 --
 -- > hc-pkg register {filename | -} [--user | --global | --package-conf]
 --
-register :: Verbosity -> ConfiguredProgram -> PackageDB
+register :: Verbosity -> ConfiguredProgram -> PackageDBStack
          -> Either FilePath
                    InstalledPackageInfo
          -> IO ()
@@ -71,7 +71,7 @@ register verbosity hcPkg packagedb pkgFile =
 --
 -- > hc-pkg register {filename | -} [--user | --global | --package-conf]
 --
-reregister :: Verbosity -> ConfiguredProgram -> PackageDB
+reregister :: Verbosity -> ConfiguredProgram -> PackageDBStack
            -> Either FilePath
                      InstalledPackageInfo
            -> IO ()
@@ -164,7 +164,7 @@ setInstalledPackageId pkginfo = pkginfo
 --
 
 registerInvocation, reregisterInvocation
-  :: ConfiguredProgram -> Verbosity -> PackageDB
+  :: ConfiguredProgram -> Verbosity -> PackageDBStack
   -> Either FilePath InstalledPackageInfo
   -> ProgramInvocation
 registerInvocation   = registerInvocation' "register"
@@ -172,22 +172,22 @@ reregisterInvocation = registerInvocation' "update"
 
 
 registerInvocation' :: String
-                    -> ConfiguredProgram -> Verbosity -> PackageDB
+                    -> ConfiguredProgram -> Verbosity -> PackageDBStack
                     -> Either FilePath InstalledPackageInfo
                     -> ProgramInvocation
-registerInvocation' cmdname hcPkg verbosity packagedb (Left pkgFile) =
+registerInvocation' cmdname hcPkg verbosity packagedbs (Left pkgFile) =
     programInvocation hcPkg args
   where
-    args = [cmdname, pkgFile, packageDbOpts packagedb]
+    args = [cmdname, pkgFile] ++ packageDbStackOpts packagedbs
         ++ verbosityOpts hcPkg verbosity
 
-registerInvocation' cmdname hcPkg verbosity packagedb (Right pkgInfo) =
+registerInvocation' cmdname hcPkg verbosity packagedbs (Right pkgInfo) =
     (programInvocation hcPkg args) {
       progInvokeInput         = Just (showInstalledPackageInfo pkgInfo),
       progInvokeInputEncoding = IOEncodingUTF8
     }
   where
-    args = [cmdname, "-", packageDbOpts packagedb]
+    args = [cmdname, "-"] ++ packageDbStackOpts packagedbs
         ++ verbosityOpts hcPkg verbosity
 
 
@@ -227,6 +227,20 @@ dumpInvocation hcPkg verbosity packagedb =
         ++ verbosityOpts hcPkg verbosity
 
 
+packageDbStackOpts :: PackageDBStack -> [String]
+packageDbStackOpts dbstack = case dbstack of
+  (GlobalPackageDB:UserPackageDB:dbs) -> "--global"
+                                       : "--user"
+                                       : map specific dbs
+  (GlobalPackageDB:dbs)               -> "--global"
+                                       : "--no-user-package-conf"
+                                       : map specific dbs
+  _                                   -> ierror
+  where
+    specific (SpecificPackageDB db) = "--package-conf=" ++ db
+    specific _ = ierror
+    ierror     = error "internal error: unexpected package db stack"
+
 packageDbOpts :: PackageDB -> String
 packageDbOpts GlobalPackageDB        = "--global"
 packageDbOpts UserPackageDB          = "--user"

Distribution/Simple/Register.hs

@@ -71,7 +71,7 @@ import Distribution.Simple.BuildPaths (haddockName)
 import qualified Distribution.Simple.GHC as GHC
 import Distribution.Simple.Compiler
          ( compilerVersion, CompilerFlavor(..), compilerFlavor
-         , PackageDB(..), registrationPackageDB )
+         , PackageDBStack, registrationPackageDB )
 import Distribution.Simple.Program
          ( ConfiguredProgram, runProgramInvocation
          , requireProgram, lookupProgram, ghcPkgProgram, lhcPkgProgram )
@@ -109,7 +109,7 @@ import System.IO.Error (try)
 
 import Control.Monad (when)
 import Data.Maybe
-         ( isJust, fromMaybe )
+         ( isJust, fromMaybe, maybeToList )
 import Data.List (partition)
 
 
@@ -131,7 +131,7 @@ register pkg@PackageDescription { library       = Just lib  }
      _ | modeGenerateRegFile   -> writeRegistrationFile installedPkgInfo
        | modeGenerateRegScript -> writeRegisterScript   installedPkgInfo
        | otherwise             -> registerPackage verbosity
-                                    installedPkgInfo pkg lbi inplace packageDb
+                                    installedPkgInfo pkg lbi inplace packageDbs
 
   where
     modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags))
@@ -141,8 +141,8 @@ register pkg@PackageDescription { library       = Just lib  }
     modeGenerateRegScript = fromFlag (regGenScript regFlags)
 
     inplace   = fromFlag (regInPlace regFlags)
-    packageDb = fromFlagOrDefault (registrationPackageDB (withPackageDB lbi))
-                                  (regPackageDB regFlags)
+    packageDbs = withPackageDB lbi
+              ++ maybeToList (flagToMaybe  (regPackageDB regFlags))
     distPref  = fromFlag (regDistPref regFlags)
     verbosity = fromFlag (regVerbosity regFlags)
 
@@ -153,9 +153,9 @@ register pkg@PackageDescription { library       = Just lib  }
     writeRegisterScript installedPkgInfo =
       case compilerFlavor (compiler lbi) of
         GHC  -> do (ghcPkg, _) <- requireProgram verbosity ghcPkgProgram (withPrograms lbi)
-                   writeHcPkgRegisterScript verbosity installedPkgInfo ghcPkg packageDb
+                   writeHcPkgRegisterScript verbosity installedPkgInfo ghcPkg packageDbs
         LHC  -> do (lhcPkg, _) <- requireProgram verbosity lhcPkgProgram (withPrograms lbi)
-                   writeHcPkgRegisterScript verbosity installedPkgInfo lhcPkg packageDb
+                   writeHcPkgRegisterScript verbosity installedPkgInfo lhcPkg packageDbs
         Hugs -> notice verbosity "Registration scripts not needed for hugs"
         JHC  -> notice verbosity "Registration scripts not needed for jhc"
         NHC  -> notice verbosity "Registration scripts not needed for nhc98"
@@ -203,14 +203,14 @@ registerPackage :: Verbosity
                 -> PackageDescription
                 -> LocalBuildInfo
                 -> Bool
-                -> PackageDB
+                -> PackageDBStack
                 -> IO ()
-registerPackage verbosity installedPkgInfo pkg lbi inplace packageDb = do
+registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs = do
   setupMessage verbosity "Registering" (packageId pkg)
   case compilerFlavor (compiler lbi) of
-    GHC  -> registerPackageGHC  verbosity installedPkgInfo pkg lbi inplace packageDb
-    LHC  -> registerPackageLHC  verbosity installedPkgInfo pkg lbi inplace packageDb
-    Hugs -> registerPackageHugs verbosity installedPkgInfo pkg lbi inplace packageDb
+    GHC  -> registerPackageGHC  verbosity installedPkgInfo pkg lbi inplace packageDbs
+    LHC  -> registerPackageLHC  verbosity installedPkgInfo pkg lbi inplace packageDbs
+    Hugs -> registerPackageHugs verbosity installedPkgInfo pkg lbi inplace packageDbs
     JHC  -> notice verbosity "Registering for jhc (nothing to do)"
     NHC  -> notice verbosity "Registering for nhc98 (nothing to do)"
     _    -> die "Registering is not implemented for this compiler"
@@ -222,17 +222,17 @@ registerPackageGHC, registerPackageLHC, registerPackageHugs
   -> PackageDescription
   -> LocalBuildInfo
   -> Bool
-  -> PackageDB
+  -> PackageDBStack
   -> IO ()
-registerPackageGHC verbosity installedPkgInfo _pkg lbi _inplace packageDb = do
+registerPackageGHC verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do
   let Just ghcPkg = lookupProgram ghcPkgProgram (withPrograms lbi)
-  HcPkg.reregister verbosity ghcPkg packageDb (Right installedPkgInfo)
+  HcPkg.reregister verbosity ghcPkg packageDbs (Right installedPkgInfo)
 
-registerPackageLHC verbosity installedPkgInfo _pkg lbi _inplace packageDb = do
+registerPackageLHC verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do
   let Just lhcPkg = lookupProgram lhcPkgProgram (withPrograms lbi)
-  HcPkg.reregister verbosity lhcPkg packageDb (Right installedPkgInfo)
+  HcPkg.reregister verbosity lhcPkg packageDbs (Right installedPkgInfo)
 
-registerPackageHugs verbosity installedPkgInfo pkg lbi inplace _packageDb = do
+registerPackageHugs verbosity installedPkgInfo pkg lbi inplace _packageDbs = do
   when inplace $ die "--inplace is not supported with Hugs"
   let installDirs = absoluteInstallDirs pkg lbi NoCopyDest
   createDirectoryIfMissingVerbose verbosity True (libdir installDirs)
@@ -243,11 +243,11 @@ registerPackageHugs verbosity installedPkgInfo pkg lbi inplace _packageDb = do
 writeHcPkgRegisterScript :: Verbosity
                          -> InstalledPackageInfo
                          -> ConfiguredProgram
-                         -> PackageDB
+                         -> PackageDBStack
                          -> IO ()
-writeHcPkgRegisterScript verbosity installedPkgInfo hcPkg packageDb = do
+writeHcPkgRegisterScript verbosity installedPkgInfo hcPkg packageDbs = do
   let invocation  = HcPkg.reregisterInvocation hcPkg Verbosity.normal
-                      packageDb (Right installedPkgInfo)
+                      packageDbs (Right installedPkgInfo)
       regScript   = invocationAsSystemScript buildOS   invocation
 
   notice verbosity ("Creating package registration script: " ++ regScriptFileName)