Add a ForceGlobalInstall 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 #1183 and interpretPackageDbFlags in D.S.Configure).
haskell · Apr 12, 2013 · 3b42456 · 3b42456
1 parent 2827948
commit 3b42456
Showing 1 changed file with 18 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' UseDefaultPackageDBStack)
+            (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' UseDefaultPackageDBStack)
+          (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 UseDefaultPackageDBStack)
        (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 UseDefaultPackageDBStack)
        (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 UseDefaultPackageDBStack)
+        (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 UseDefaultPackageDBStack)
             comp
             conf
             initFlags
@@ -623,11 +626,17 @@ win32SelfUpgradeAction _ _ _ = return ()
 -- Utils (transitionary)
 --
 
-configPackageDB' :: ConfigFlags -> PackageDBStack
-configPackageDB' cfg =
+data ForceGlobalInstall = ForceGlobalInstall
+                        | UseDefaultPackageDBStack
+
+
+configPackageDB' :: ConfigFlags -> ForceGlobalInstall -> PackageDBStack
+configPackageDB' cfg force =
     interpretPackageDbFlags userInstall (configPackageDBs cfg)
   where
-    userInstall = fromFlagOrDefault True (configUserInstall cfg)
+    userInstall = case force of
+      ForceGlobalInstall       -> False
+      UseDefaultPackageDBStack -> fromFlagOrDefault True (configUserInstall cfg)
 
 configCompilerAux' :: ConfigFlags
                    -> IO (Compiler, Platform, ProgramConfiguration)