Add a ForceGlobalInstall argument to configPackageDB'.

In sandbox mode userInstallDirs = globalInstallDirs and we set userInstall to False to prevent UserPackageDB from being added to the package DB stack (see haskell#1183).
23Skidoo · Mar 24, 2013 · a2d98b8 · a2d98b8
1 parent 0c9284f
commit a2d98b8
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)