SavedConfig Monoid instance: make list fields work like Flags.

cabal-install/Distribution/Client/Config.hs

@@ -50,7 +50,7 @@ import Distribution.Client.Setup
          , ReportFlags(..), reportCommand
          , showRepo, parseRepo )
 import Distribution.Utils.NubList
-         ( fromNubList, toNubList)
+         ( NubList, fromNubList, toNubList)
 
 import Distribution.Simple.Compiler
          ( OptimisationLevel(..) )
@@ -150,17 +150,217 @@ instance Monoid SavedConfig where
     savedHaddockFlags      = mempty
   }
   mappend a b = SavedConfig {
-    savedGlobalFlags       = combine savedGlobalFlags,
-    savedInstallFlags      = combine savedInstallFlags,
-    savedConfigureFlags    = combine savedConfigureFlags,
-    savedConfigureExFlags  = combine savedConfigureExFlags,
-    savedUserInstallDirs   = combine savedUserInstallDirs,
-    savedGlobalInstallDirs = combine savedGlobalInstallDirs,
-    savedUploadFlags       = combine savedUploadFlags,
-    savedReportFlags       = combine savedReportFlags,
-    savedHaddockFlags      = combine savedHaddockFlags
+    savedGlobalFlags       = combinedSavedGlobalFlags,
+    savedInstallFlags      = combinedSavedInstallFlags,
+    savedConfigureFlags    = combinedSavedConfigureFlags,
+    savedConfigureExFlags  = combinedSavedConfigureExFlags,
+    savedUserInstallDirs   = combinedSavedUserInstallDirs,
+    savedGlobalInstallDirs = combinedSavedGlobalInstallDirs,
+    savedUploadFlags       = combinedSavedUploadFlags,
+    savedReportFlags       = combinedSavedReportFlags,
+    savedHaddockFlags      = combinedSavedHaddockFlags
   }
-    where combine field = field a `mappend` field b
+    where
+      -- This is ugly, but necessary. If we're mappending two config files, we
+      -- want the values of the *non-empty* list fields from the second one to
+      -- *override* the corresponding values from the first one. Default
+      -- behaviour (concatenation) is confusing and makes some use cases (see
+      -- #1884) impossible.
+      --
+      -- However, we also want to allow specifying multiple values for a list
+      -- field in a *single* config file. For example, we want the following to
+      -- continue to work:
+      --
+      -- remote-repo: hackage.haskell.org:http://hackage.haskell.org/
+      -- remote-repo: private-collection:http://hackage.local/
+      --
+      -- So we can't just wrap the list fields inside Flags; we have to do some
+      -- special-casing just for SavedConfig.
+
+      -- NB: the signature prevents us from using 'combine' on lists.
+      combine' :: (SavedConfig -> flags) -> (flags -> Flag a) -> Flag a
+      combine'        field subfield =
+        (subfield . field $ a) `mappend` (subfield . field $ b)
+
+      lastNonEmpty' :: (SavedConfig -> flags) -> (flags -> [a]) -> [a]
+      lastNonEmpty'   field subfield =
+        let a' = subfield . field $ a
+            b' = subfield . field $ b
+        in case b' of [] -> a'
+                      _  -> b'
+
+      lastNonEmptyNL' :: (SavedConfig -> flags) -> (flags -> NubList a)
+                      -> NubList a
+      lastNonEmptyNL' field subfield =
+        let a' = subfield . field $ a
+            b' = subfield . field $ b
+        in case fromNubList b' of [] -> a'
+                                  _  -> b'
+
+      combinedSavedGlobalFlags = GlobalFlags {
+        globalVersion           = combine globalVersion,
+        globalNumericVersion    = combine globalNumericVersion,
+        globalConfigFile        = combine globalConfigFile,
+        globalSandboxConfigFile = combine globalSandboxConfigFile,
+        globalRemoteRepos       = lastNonEmptyNL globalRemoteRepos,
+        globalCacheDir          = combine globalCacheDir,
+        globalLocalRepos        = lastNonEmptyNL globalLocalRepos,
+        globalLogsDir           = combine globalLogsDir,
+        globalWorldFile         = combine globalWorldFile,
+        globalRequireSandbox    = combine globalRequireSandbox,
+        globalIgnoreSandbox     = combine globalIgnoreSandbox
+        }
+        where
+          combine        = combine'        savedGlobalFlags
+          lastNonEmptyNL = lastNonEmptyNL' savedGlobalFlags
+
+      combinedSavedInstallFlags = InstallFlags {
+        installDocumentation         = combine installDocumentation,
+        installHaddockIndex          = combine installHaddockIndex,
+        installDryRun                = combine installDryRun,
+        installMaxBackjumps          = combine installMaxBackjumps,
+        installReorderGoals          = combine installReorderGoals,
+        installIndependentGoals      = combine installIndependentGoals,
+        installShadowPkgs            = combine installShadowPkgs,
+        installStrongFlags           = combine installStrongFlags,
+        installReinstall             = combine installReinstall,
+        installAvoidReinstalls       = combine installAvoidReinstalls,
+        installOverrideReinstall     = combine installOverrideReinstall,
+        installUpgradeDeps           = combine installUpgradeDeps,
+        installOnly                  = combine installOnly,
+        installOnlyDeps              = combine installOnlyDeps,
+        installRootCmd               = combine installRootCmd,
+        installSummaryFile           = lastNonEmptyNL installSummaryFile,
+        installLogFile               = combine installLogFile,
+        installBuildReports          = combine installBuildReports,
+        installReportPlanningFailure = combine installReportPlanningFailure,
+        installSymlinkBinDir         = combine installSymlinkBinDir,
+        installOneShot               = combine installOneShot,
+        installNumJobs               = combine installNumJobs,
+        installRunTests              = combine installRunTests
+        }
+        where
+          combine        = combine'        savedInstallFlags
+          lastNonEmptyNL = lastNonEmptyNL' savedInstallFlags
+
+      combinedSavedConfigureFlags = ConfigFlags {
+        configPrograms            = configPrograms . savedConfigureFlags $ b,
+        -- TODO: NubListify
+        configProgramPaths        = lastNonEmpty configProgramPaths,
+        -- TODO: NubListify
+        configProgramArgs         = lastNonEmpty configProgramArgs,
+        configProgramPathExtra    = lastNonEmptyNL configProgramPathExtra,
+        configHcFlavor            = combine configHcFlavor,
+        configHcPath              = combine configHcPath,
+        configHcPkg               = combine configHcPkg,
+        configVanillaLib          = combine configVanillaLib,
+        configProfLib             = combine configProfLib,
+        configSharedLib           = combine configSharedLib,
+        configDynExe              = combine configDynExe,
+        configProfExe             = combine configProfExe,
+        -- TODO: NubListify
+        configConfigureArgs       = lastNonEmpty configConfigureArgs,
+        configOptimization        = combine configOptimization,
+        configProgPrefix          = combine configProgPrefix,
+        configProgSuffix          = combine configProgSuffix,
+        -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'.
+        configInstallDirs         =
+          (configInstallDirs . savedConfigureFlags $ a)
+          `mappend` (configInstallDirs . savedConfigureFlags $ b),
+        configScratchDir          = combine configScratchDir,
+        -- TODO: NubListify
+        configExtraLibDirs        = lastNonEmpty configExtraLibDirs,
+        -- TODO: NubListify
+        configExtraIncludeDirs    = lastNonEmpty configExtraIncludeDirs,
+        configDistPref            = combine configDistPref,
+        configVerbosity           = combine configVerbosity,
+        configUserInstall         = combine configUserInstall,
+        -- TODO: NubListify
+        configPackageDBs          = lastNonEmpty configPackageDBs,
+        configGHCiLib             = combine configGHCiLib,
+        configSplitObjs           = combine configSplitObjs,
+        configStripExes           = combine configStripExes,
+        configStripLibs           = combine configStripLibs,
+        -- TODO: NubListify
+        configConstraints         = lastNonEmpty configConstraints,
+        -- TODO: NubListify
+        configDependencies        = lastNonEmpty configDependencies,
+        -- TODO: NubListify
+        configConfigurationsFlags = lastNonEmpty configConfigurationsFlags,
+        configTests               = combine configTests,
+        configBenchmarks          = combine configBenchmarks,
+        configCoverage            = combine configCoverage,
+        configLibCoverage         = combine configLibCoverage,
+        configExactConfiguration  = combine configExactConfiguration,
+        configFlagError           = combine configFlagError
+        }
+        where
+          combine        = combine'        savedConfigureFlags
+          lastNonEmpty   = lastNonEmpty'   savedConfigureFlags
+          lastNonEmptyNL = lastNonEmptyNL' savedConfigureFlags
+
+      combinedSavedConfigureExFlags = ConfigExFlags {
+        configCabalVersion  = combine configCabalVersion,
+        -- TODO: NubListify
+        configExConstraints = lastNonEmpty configExConstraints,
+        -- TODO: NubListify
+        configPreferences   = lastNonEmpty configPreferences,
+        configSolver        = combine configSolver,
+        configAllowNewer    = combine configAllowNewer
+        }
+        where
+          combine      = combine' savedConfigureExFlags
+          lastNonEmpty = lastNonEmpty' savedConfigureExFlags
+
+      -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'.
+      combinedSavedUserInstallDirs = savedUserInstallDirs a
+                                     `mappend` savedUserInstallDirs b
+
+      -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'.
+      combinedSavedGlobalInstallDirs = savedGlobalInstallDirs a
+                                       `mappend` savedGlobalInstallDirs b
+
+      combinedSavedUploadFlags = UploadFlags {
+        uploadCheck     = combine uploadCheck,
+        uploadUsername  = combine uploadUsername,
+        uploadPassword  = combine uploadPassword,
+        uploadVerbosity = combine uploadVerbosity
+        }
+        where
+          combine = combine' savedUploadFlags
+
+      combinedSavedReportFlags = ReportFlags {
+        reportUsername  = combine reportUsername,
+        reportPassword  = combine reportPassword,
+        reportVerbosity = combine reportVerbosity
+        }
+        where
+          combine = combine' savedReportFlags
+
+      combinedSavedHaddockFlags = HaddockFlags {
+        -- TODO: NubListify
+        haddockProgramPaths  = lastNonEmpty haddockProgramPaths,
+        -- TODO: NubListify
+        haddockProgramArgs   = lastNonEmpty haddockProgramArgs,
+        haddockHoogle        = combine haddockHoogle,
+        haddockHtml          = combine haddockHtml,
+        haddockHtmlLocation  = combine haddockHtmlLocation,
+        haddockExecutables   = combine haddockExecutables,
+        haddockTestSuites    = combine haddockTestSuites,
+        haddockBenchmarks    = combine haddockBenchmarks,
+        haddockInternal      = combine haddockInternal,
+        haddockCss           = combine haddockCss,
+        haddockHscolour      = combine haddockHscolour,
+        haddockHscolourCss   = combine haddockHscolourCss,
+        haddockContents      = combine haddockContents,
+        haddockDistPref      = combine haddockDistPref,
+        haddockKeepTempFiles = combine haddockKeepTempFiles,
+        haddockVerbosity     = combine haddockVerbosity
+        }
+        where
+          combine      = combine'        savedHaddockFlags
+          lastNonEmpty = lastNonEmpty'   savedHaddockFlags
+
 
 updateInstallDirs :: Flag Bool -> SavedConfig -> SavedConfig
 updateInstallDirs userInstallFlag

cabal-install/Main.hs

@@ -861,7 +861,7 @@ updateAction verbosityFlag extraArgs globalFlags = do
   unless (null extraArgs) $
     die $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs
   let verbosity = fromFlag verbosityFlag
-  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty
+  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags NoFlag
   let globalFlags' = savedGlobalFlags config `mappend` globalFlags
   update verbosity (globalRepos globalFlags')