Add a ForcePackageDBStack argument to configPackageDB'.

We use userInstallDirs in sandbox mode to prevent cabal-install from doing unnecessary things like invoking itself via 'sudo' (see commit 7b2e363 and 'rootCmd' in D.C.Install), but in this particular case we want userInstall to be False to prevent UserPackageDB from being added to the package DB stack (see haskell#1183 and interpretPackageDbFlags in D.S.Configure).
23Skidoo · Mar 24, 2013 · 39af2cb · 39af2cb
1 parent 0c9284f
commit 39af2cb
Showing 1 changed file with 17 additions and 9 deletions.
diff --git a/cabal-install/Main.hs b/cabal-install/Main.hs
@@ -205,7 +205,8 @@ configureAction (configFlags, configExFlags) extraArgs globalFlags = do
       globalFlags'   = savedGlobalFlags      config `mappend` globalFlags
   (comp, platform, conf) <- configCompilerAux configFlags'
   configure verbosity
-            (configPackageDB' configFlags') (globalRepos globalFlags')
+            (configPackageDB' configFlags' DontForceGlobalInstall)
+            (globalRepos globalFlags')
             comp platform conf configFlags' configExFlags' extraArgs
 
 buildAction :: BuildFlags -> [String] -> GlobalFlags -> IO ()
@@ -376,7 +377,8 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags)
       globalFlags'   = savedGlobalFlags      config `mappend` globalFlags
   (comp, platform, conf) <- configCompilerAux' configFlags'
   install verbosity
-          (configPackageDB' configFlags') (globalRepos globalFlags')
+          (configPackageDB' configFlags' DontForceGlobalInstall)
+          (globalRepos globalFlags')
           comp platform conf globalFlags' configFlags' configExFlags'
           installFlags' haddockFlags
           targets
@@ -423,7 +425,7 @@ listAction listFlags extraArgs globalFlags = do
       globalFlags' = savedGlobalFlags    config `mappend` globalFlags
   (comp, _, conf) <- configCompilerAux' configFlags
   list verbosity
-       (configPackageDB' configFlags)
+       (configPackageDB' configFlags DontForceGlobalInstall)
        (globalRepos globalFlags')
        comp
        conf
@@ -439,7 +441,7 @@ infoAction infoFlags extraArgs globalFlags = do
       globalFlags' = savedGlobalFlags    config `mappend` globalFlags
   (comp, _, conf) <- configCompilerAux configFlags
   info verbosity
-       (configPackageDB' configFlags)
+       (configPackageDB' configFlags DontForceGlobalInstall)
        (globalRepos globalFlags')
        comp
        conf
@@ -480,7 +482,8 @@ fetchAction fetchFlags extraArgs globalFlags = do
       globalFlags' = savedGlobalFlags config `mappend` globalFlags
   (comp, platform, conf) <- configCompilerAux' configFlags
   fetch verbosity
-        (configPackageDB' configFlags) (globalRepos globalFlags')
+        (configPackageDB' configFlags DontForceGlobalInstall)
+        (globalRepos globalFlags')
         comp platform conf globalFlags' fetchFlags
         targets
 
@@ -582,7 +585,7 @@ initAction initFlags _extraArgs globalFlags = do
   let configFlags  = savedConfigureFlags config
   (comp, _, conf) <- configCompilerAux' configFlags
   initCabal verbosity
-            (configPackageDB' configFlags)
+            (configPackageDB' configFlags DontForceGlobalInstall)
             comp
             conf
             initFlags
@@ -623,11 +626,16 @@ win32SelfUpgradeAction _ _ _ = return ()
 -- Utils (transitionary)
 --
 
-configPackageDB' :: ConfigFlags -> PackageDBStack
-configPackageDB' cfg =
+data ForceGlobalInstall = DontForceGlobalInstall
+                        | ForceGlobalInstall
+
+configPackageDB' :: ConfigFlags -> ForceGlobalInstall -> PackageDBStack
+configPackageDB' cfg force =
     interpretPackageDbFlags userInstall (configPackageDBs cfg)
   where
-    userInstall = fromFlagOrDefault True (configUserInstall cfg)
+    userInstall = case force of
+      ForceGlobalInstall     -> False
+      DontForceGlobalInstall -> fromFlagOrDefault True (configUserInstall cfg)
 
 configCompilerAux' :: ConfigFlags
                    -> IO (Compiler, Platform, ProgramConfiguration)