Commit 7e744fe3 authored by Mikhail Glushenkov's avatar Mikhail Glushenkov

SavedConfig Monoid instance: make list fields work like Flags.

Fixes #1884. See code comments for more details.
parent 6f6c5b62
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment