Commit ec6dd74d authored by Herbert Valerio Riedel's avatar Herbert Valerio Riedel 🕺
Browse files

Derive some Semigroup/Monoid instances via Generics

This increases compile-time (until GHC becomes more clever) but the
generated code is expected to be at least as good (if not better) than
the manually generated code.

This addresses #3169
parent 9b38b38b
......@@ -111,7 +111,7 @@ module Distribution.PackageDescription (
import Distribution.Compat.Binary
import qualified Distribution.Compat.Semigroup as Semi ((<>))
import Distribution.Compat.Semigroup as Semi (Monoid(..), Semigroup)
import Distribution.Compat.Semigroup as Semi (Monoid(..), Semigroup, gmempty, gmappend)
import qualified Distribution.Compat.ReadP as Parse
import Distribution.Compat.ReadP ((<++))
import Distribution.Package
......@@ -314,15 +314,12 @@ data SetupBuildInfo = SetupBuildInfo {
instance Binary SetupBuildInfo
instance Monoid SetupBuildInfo where
mempty = SetupBuildInfo {
setupDepends = Semi.mempty
}
instance Semi.Monoid SetupBuildInfo where
mempty = gmempty
mappend = (Semi.<>)
instance Semigroup SetupBuildInfo where
a <> b = SetupBuildInfo { setupDepends = combine setupDepends }
where combine field = field a `mappend` field b
(<>) = gmappend
-- ---------------------------------------------------------------------------
-- Module renaming
......@@ -498,11 +495,7 @@ data Executable = Executable {
instance Binary Executable
instance Monoid Executable where
mempty = Executable {
exeName = mempty,
modulePath = mempty,
buildInfo = mempty
}
mempty = gmempty
mappend = (Semi.<>)
instance Semigroup Executable where
......
......@@ -763,46 +763,11 @@ exeBuildDir lbi exe = buildDir lbi </> exeName exe </> exeName exe ++ "-tmp"
-- ------------------------------------------------------------------------------
-- Boilerplate Monoid instance.
instance Monoid HaddockArgs where
mempty = HaddockArgs {
argInterfaceFile = mempty,
argPackageName = mempty,
argHideModules = mempty,
argIgnoreExports = mempty,
argLinkSource = mempty,
argCssFile = mempty,
argContents = mempty,
argVerbose = mempty,
argOutput = mempty,
argInterfaces = mempty,
argOutputDir = mempty,
argTitle = mempty,
argPrologue = mempty,
argGhcOptions = mempty,
argGhcLibDir = mempty,
argTargets = mempty
}
mempty = gmempty
mappend = (Semi.<>)
instance Semigroup HaddockArgs where
a <> b = HaddockArgs {
argInterfaceFile = mult argInterfaceFile,
argPackageName = mult argPackageName,
argHideModules = mult argHideModules,
argIgnoreExports = mult argIgnoreExports,
argLinkSource = mult argLinkSource,
argCssFile = mult argCssFile,
argContents = mult argContents,
argVerbose = mult argVerbose,
argOutput = mult argOutput,
argInterfaces = mult argInterfaces,
argOutputDir = mult argOutputDir,
argTitle = mult argTitle,
argPrologue = mult argPrologue,
argGhcOptions = mult argGhcOptions,
argGhcLibDir = mult argGhcLibDir,
argTargets = mult argTargets
}
where mult f = f a `mappend` f b
(<>) = gmappend
instance Monoid Directory where
mempty = Dir "."
......
......@@ -113,26 +113,11 @@ instance Functor InstallDirs where
}
instance (Semigroup dir, Monoid dir) => Monoid (InstallDirs dir) where
mempty = InstallDirs {
prefix = mempty,
bindir = mempty,
libdir = mempty,
libsubdir = mempty,
dynlibdir = mempty,
libexecdir = mempty,
includedir = mempty,
datadir = mempty,
datasubdir = mempty,
docdir = mempty,
mandir = mempty,
htmldir = mempty,
haddockdir = mempty,
sysconfdir = mempty
}
mempty = gmempty
mappend = (Semi.<>)
instance Semigroup dir => Semigroup (InstallDirs dir) where
(<>) = combineInstallDirs (<>)
(<>) = gmappend
combineInstallDirs :: (a -> b -> c)
-> InstallDirs a
......
......@@ -499,116 +499,8 @@ packageDbArgs implInfo
-- Boilerplate Monoid instance for GhcOptions
instance Monoid GhcOptions where
mempty = GhcOptions {
ghcOptMode = mempty,
ghcOptExtra = mempty,
ghcOptExtraDefault = mempty,
ghcOptInputFiles = mempty,
ghcOptInputModules = mempty,
ghcOptOutputFile = mempty,
ghcOptOutputDynFile = mempty,
ghcOptSourcePathClear = mempty,
ghcOptSourcePath = mempty,
ghcOptThisUnitId = mempty,
ghcOptPackageDBs = mempty,
ghcOptPackages = mempty,
ghcOptHideAllPackages = mempty,
ghcOptNoAutoLinkPackages = mempty,
ghcOptLinkLibs = mempty,
ghcOptLinkLibPath = mempty,
ghcOptLinkOptions = mempty,
ghcOptLinkFrameworks = mempty,
ghcOptLinkFrameworkDirs = mempty,
ghcOptNoLink = mempty,
ghcOptLinkNoHsMain = mempty,
ghcOptCcOptions = mempty,
ghcOptCppOptions = mempty,
ghcOptCppIncludePath = mempty,
ghcOptCppIncludes = mempty,
ghcOptFfiIncludes = mempty,
ghcOptLanguage = mempty,
ghcOptExtensions = mempty,
ghcOptExtensionMap = mempty,
ghcOptOptimisation = mempty,
ghcOptDebugInfo = mempty,
ghcOptProfilingMode = mempty,
ghcOptProfilingAuto = mempty,
ghcOptSplitObjs = mempty,
ghcOptNumJobs = mempty,
ghcOptHPCDir = mempty,
ghcOptGHCiScripts = mempty,
ghcOptHiSuffix = mempty,
ghcOptObjSuffix = mempty,
ghcOptDynHiSuffix = mempty,
ghcOptDynObjSuffix = mempty,
ghcOptHiDir = mempty,
ghcOptObjDir = mempty,
ghcOptOutputDir = mempty,
ghcOptStubDir = mempty,
ghcOptDynLinkMode = mempty,
ghcOptShared = mempty,
ghcOptFPic = mempty,
ghcOptDylibName = mempty,
ghcOptRPaths = mempty,
ghcOptVerbosity = mempty,
ghcOptCabal = mempty
}
mempty = gmempty
mappend = (Semi.<>)
instance Semigroup GhcOptions where
a <> b = GhcOptions {
ghcOptMode = combine ghcOptMode,
ghcOptExtra = combine ghcOptExtra,
ghcOptExtraDefault = combine ghcOptExtraDefault,
ghcOptInputFiles = combine ghcOptInputFiles,
ghcOptInputModules = combine ghcOptInputModules,
ghcOptOutputFile = combine ghcOptOutputFile,
ghcOptOutputDynFile = combine ghcOptOutputDynFile,
ghcOptSourcePathClear = combine ghcOptSourcePathClear,
ghcOptSourcePath = combine ghcOptSourcePath,
ghcOptThisUnitId = combine ghcOptThisUnitId,
ghcOptPackageDBs = combine ghcOptPackageDBs,
ghcOptPackages = combine ghcOptPackages,
ghcOptHideAllPackages = combine ghcOptHideAllPackages,
ghcOptNoAutoLinkPackages = combine ghcOptNoAutoLinkPackages,
ghcOptLinkLibs = combine ghcOptLinkLibs,
ghcOptLinkLibPath = combine ghcOptLinkLibPath,
ghcOptLinkOptions = combine ghcOptLinkOptions,
ghcOptLinkFrameworks = combine ghcOptLinkFrameworks,
ghcOptLinkFrameworkDirs = combine ghcOptLinkFrameworkDirs,
ghcOptNoLink = combine ghcOptNoLink,
ghcOptLinkNoHsMain = combine ghcOptLinkNoHsMain,
ghcOptCcOptions = combine ghcOptCcOptions,
ghcOptCppOptions = combine ghcOptCppOptions,
ghcOptCppIncludePath = combine ghcOptCppIncludePath,
ghcOptCppIncludes = combine ghcOptCppIncludes,
ghcOptFfiIncludes = combine ghcOptFfiIncludes,
ghcOptLanguage = combine ghcOptLanguage,
ghcOptExtensions = combine ghcOptExtensions,
ghcOptExtensionMap = combine ghcOptExtensionMap,
ghcOptOptimisation = combine ghcOptOptimisation,
ghcOptDebugInfo = combine ghcOptDebugInfo,
ghcOptProfilingMode = combine ghcOptProfilingMode,
ghcOptProfilingAuto = combine ghcOptProfilingAuto,
ghcOptSplitObjs = combine ghcOptSplitObjs,
ghcOptNumJobs = combine ghcOptNumJobs,
ghcOptHPCDir = combine ghcOptHPCDir,
ghcOptGHCiScripts = combine ghcOptGHCiScripts,
ghcOptHiSuffix = combine ghcOptHiSuffix,
ghcOptObjSuffix = combine ghcOptObjSuffix,
ghcOptDynHiSuffix = combine ghcOptDynHiSuffix,
ghcOptDynObjSuffix = combine ghcOptDynObjSuffix,
ghcOptHiDir = combine ghcOptHiDir,
ghcOptObjDir = combine ghcOptObjDir,
ghcOptOutputDir = combine ghcOptOutputDir,
ghcOptStubDir = combine ghcOptStubDir,
ghcOptDynLinkMode = combine ghcOptDynLinkMode,
ghcOptShared = combine ghcOptShared,
ghcOptFPic = combine ghcOptFPic,
ghcOptDylibName = combine ghcOptDylibName,
ghcOptRPaths = combine ghcOptRPaths,
ghcOptVerbosity = combine ghcOptVerbosity,
ghcOptCabal = combine ghcOptCabal
}
where
combine field = field a `mappend` field b
(<>) = gmappend
......@@ -239,18 +239,11 @@ emptyGlobalFlags :: GlobalFlags
emptyGlobalFlags = mempty
instance Monoid GlobalFlags where
mempty = GlobalFlags {
globalVersion = mempty,
globalNumericVersion = mempty
}
mempty = gmempty
mappend = (Semi.<>)
instance Semigroup GlobalFlags where
a <> b = GlobalFlags {
globalVersion = combine globalVersion,
globalNumericVersion = combine globalNumericVersion
}
where combine field = field a `mappend` field b
(<>) = gmappend
-- ------------------------------------------------------------
-- * Config flags
......@@ -811,104 +804,11 @@ emptyConfigFlags :: ConfigFlags
emptyConfigFlags = mempty
instance Monoid ConfigFlags where
mempty = ConfigFlags {
configPrograms = mempty,
configProgramPaths = mempty,
configProgramArgs = mempty,
configProgramPathExtra = mempty,
configHcFlavor = mempty,
configHcPath = mempty,
configHcPkg = mempty,
configVanillaLib = mempty,
configProfLib = mempty,
configSharedLib = mempty,
configDynExe = mempty,
configProfExe = mempty,
configProf = mempty,
configProfDetail = mempty,
configProfLibDetail = mempty,
configConfigureArgs = mempty,
configOptimization = mempty,
configProgPrefix = mempty,
configProgSuffix = mempty,
configInstallDirs = mempty,
configScratchDir = mempty,
configDistPref = mempty,
configVerbosity = mempty,
configUserInstall = mempty,
configPackageDBs = mempty,
configGHCiLib = mempty,
configSplitObjs = mempty,
configStripExes = mempty,
configStripLibs = mempty,
configExtraLibDirs = mempty,
configExtraFrameworkDirs = mempty,
configConstraints = mempty,
configDependencies = mempty,
configExtraIncludeDirs = mempty,
configIPID = mempty,
configConfigurationsFlags = mempty,
configTests = mempty,
configCoverage = mempty,
configLibCoverage = mempty,
configExactConfiguration = mempty,
configBenchmarks = mempty,
configFlagError = mempty,
configRelocatable = mempty,
configDebugInfo = mempty,
configAllowNewer = mempty
}
mempty = gmempty
mappend = (Semi.<>)
instance Semigroup ConfigFlags where
a <> b = ConfigFlags {
configPrograms = combine configPrograms,
configProgramPaths = combine configProgramPaths,
configProgramArgs = combine configProgramArgs,
configProgramPathExtra = combine 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,
configProf = combine configProf,
configProfDetail = combine configProfDetail,
configProfLibDetail = combine configProfLibDetail,
configConfigureArgs = combine configConfigureArgs,
configOptimization = combine configOptimization,
configProgPrefix = combine configProgPrefix,
configProgSuffix = combine configProgSuffix,
configInstallDirs = combine configInstallDirs,
configScratchDir = combine configScratchDir,
configDistPref = combine configDistPref,
configVerbosity = combine configVerbosity,
configUserInstall = combine configUserInstall,
configPackageDBs = combine configPackageDBs,
configGHCiLib = combine configGHCiLib,
configSplitObjs = combine configSplitObjs,
configStripExes = combine configStripExes,
configStripLibs = combine configStripLibs,
configExtraLibDirs = combine configExtraLibDirs,
configExtraFrameworkDirs = combine configExtraFrameworkDirs,
configConstraints = combine configConstraints,
configDependencies = combine configDependencies,
configExtraIncludeDirs = combine configExtraIncludeDirs,
configIPID = combine configIPID,
configConfigurationsFlags = combine configConfigurationsFlags,
configTests = combine configTests,
configCoverage = combine configCoverage,
configLibCoverage = combine configLibCoverage,
configExactConfiguration = combine configExactConfiguration,
configBenchmarks = combine configBenchmarks,
configFlagError = combine configFlagError,
configRelocatable = combine configRelocatable,
configDebugInfo = combine configDebugInfo,
configAllowNewer = combine configAllowNewer
}
where combine field = field a `mappend` field b
(<>) = gmappend
-- ------------------------------------------------------------
-- * Copy flags
......@@ -959,20 +859,11 @@ emptyCopyFlags :: CopyFlags
emptyCopyFlags = mempty
instance Monoid CopyFlags where
mempty = CopyFlags {
copyDest = mempty,
copyDistPref = mempty,
copyVerbosity = mempty
}
mempty = gmempty
mappend = (Semi.<>)
instance Semigroup CopyFlags where
a <> b = CopyFlags {
copyDest = combine copyDest,
copyDistPref = combine copyDistPref,
copyVerbosity = combine copyVerbosity
}
where combine field = field a `mappend` field b
(<>) = gmappend
-- ------------------------------------------------------------
-- * Install flags
......@@ -1039,24 +930,11 @@ emptyInstallFlags :: InstallFlags
emptyInstallFlags = mempty
instance Monoid InstallFlags where
mempty = InstallFlags{
installPackageDB = mempty,
installDistPref = mempty,
installUseWrapper = mempty,
installInPlace = mempty,
installVerbosity = mempty
}
mempty = gmempty
mappend = (Semi.<>)
instance Semigroup InstallFlags where
a <> b = InstallFlags{
installPackageDB = combine installPackageDB,
installDistPref = combine installDistPref,
installUseWrapper = combine installUseWrapper,
installInPlace = combine installInPlace,
installVerbosity = combine installVerbosity
}
where combine field = field a `mappend` field b
(<>) = gmappend
-- ------------------------------------------------------------
-- * SDist flags
......@@ -1119,24 +997,11 @@ emptySDistFlags :: SDistFlags
emptySDistFlags = mempty
instance Monoid SDistFlags where
mempty = SDistFlags {
sDistSnapshot = mempty,
sDistDirectory = mempty,
sDistDistPref = mempty,
sDistListSources = mempty,
sDistVerbosity = mempty
}
mempty = gmempty
mappend = (Semi.<>)
instance Semigroup SDistFlags where
a <> b = SDistFlags {
sDistSnapshot = combine sDistSnapshot,
sDistDirectory = combine sDistDirectory,
sDistDistPref = combine sDistDistPref,
sDistListSources = combine sDistListSources,
sDistVerbosity = combine sDistVerbosity
}
where combine field = field a `mappend` field b
(<>) = gmappend
-- ------------------------------------------------------------
-- * Register flags
......@@ -1245,28 +1110,11 @@ emptyRegisterFlags :: RegisterFlags
emptyRegisterFlags = mempty
instance Monoid RegisterFlags where
mempty = RegisterFlags {
regPackageDB = mempty,
regGenScript = mempty,
regGenPkgConf = mempty,
regInPlace = mempty,
regPrintId = mempty,
regDistPref = mempty,
regVerbosity = mempty
}
mempty = gmempty
mappend = (Semi.<>)
instance Semigroup RegisterFlags where
a <> b = RegisterFlags {
regPackageDB = combine regPackageDB,
regGenScript = combine regGenScript,
regGenPkgConf = combine regGenPkgConf,
regInPlace = combine regInPlace,
regPrintId = combine regPrintId,
regDistPref = combine regDistPref,
regVerbosity = combine regVerbosity
}
where combine field = field a `mappend` field b
(<>) = gmappend
-- ------------------------------------------------------------
-- * HsColour flags
......@@ -1296,26 +1144,11 @@ defaultHscolourFlags = HscolourFlags {
}
instance Monoid HscolourFlags where
mempty = HscolourFlags {
hscolourCSS = mempty,
hscolourExecutables = mempty,
hscolourTestSuites = mempty,
hscolourBenchmarks = mempty,
hscolourDistPref = mempty,
hscolourVerbosity = mempty
}
mempty = gmempty
mappend = (Semi.<>)
instance Semigroup HscolourFlags where
a <> b = HscolourFlags {
hscolourCSS = combine hscolourCSS,
hscolourExecutables = combine hscolourExecutables,
hscolourTestSuites = combine hscolourTestSuites,
hscolourBenchmarks = combine hscolourBenchmarks,
hscolourDistPref = combine hscolourDistPref,
hscolourVerbosity = combine hscolourVerbosity
}
where combine field = field a `mappend` field b
(<>) = gmappend
hscolourCommand :: CommandUI HscolourFlags
hscolourCommand = CommandUI
......@@ -1526,48 +1359,11 @@ emptyHaddockFlags :: HaddockFlags
emptyHaddockFlags = mempty
instance Monoid HaddockFlags where
mempty = HaddockFlags {
haddockProgramPaths = mempty,
haddockProgramArgs = mempty,
haddockHoogle = mempty,
haddockHtml = mempty,
haddockHtmlLocation = mempty,
haddockForHackage = mempty,
haddockExecutables = mempty,
haddockTestSuites = mempty,
haddockBenchmarks = mempty,
haddockInternal = mempty,
haddockCss = mempty,
haddockHscolour = mempty,
haddockHscolourCss = mempty,
haddockContents = mempty,
haddockDistPref = mempty,
haddockKeepTempFiles= mempty,
haddockVerbosity = mempty
}
mempty = gmempty
mappend = (Semi.<>)
instance Semigroup HaddockFlags where
a <> b = HaddockFlags {
haddockProgramPaths = combine haddockProgramPaths,
haddockProgramArgs = combine haddockProgramArgs,
haddockHoogle = combine haddockHoogle,
haddockHtml = combine haddockHtml,
haddockHtmlLocation = combine haddockHtmlLocation,
haddockForHackage = combine haddockForHackage,
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 field = field a `mappend` field b
(<>) = gmappend
-- ------------------------------------------------------------
-- * Clean flags
......@@ -1614,20 +1410,11 @@ emptyCleanFlags :: CleanFlags
emptyCleanFlags = mempty
instance Monoid CleanFlags where
mempty = CleanFlags {
cleanSaveConf = mempty,
cleanDistPref = mempty,
cleanVerbosity = mempty
}
mempty = gmempty
mappend = (Semi.<>)
instance Semigroup CleanFlags where
a <> b = CleanFlags {
cleanSaveConf = combine cleanSaveConf,
cleanDistPref = combine cleanDistPref,
cleanVerbosity = combine cleanVerbosity
}
where combine field = field a `mappend` field b
(<>) = gmappend
-- ------------------------------------------------------------
-- * Build flags
......@@ -1718,26 +1505,11 @@ emptyBuildFlags :: BuildFlags
emptyBuildFlags = mempty
instance Monoid BuildFlags where
mempty = BuildFlags {
buildProgramPaths = mempty,
buildProgramArgs = mempty,
buildVerbosity = mempty,
buildDistPref = mempty,
buildNumJobs = mempty,
buildArgs = mempty
}
mempty = gmempty
mappend = (Semi.<>)
instance Semigroup BuildFlags where
a <> b = BuildFlags {
buildProgramPaths = combine buildProgramPaths,
buildProgramArgs = combine buildProgramArgs,
buildVerbosity = combine buildVerbosity,
buildDistPref = combine buildDistPref,
buildNumJobs = combine buildNumJobs,
buildArgs = combine buildArgs
}
where combine field = field a `mappend` field b
(<>) = gmappend
-- ------------------------------------------------------------
-- * REPL Flags
......@@ -1762,24 +1534,11 @@ defaultReplFlags = ReplFlags {
}
instance Monoid ReplFlags where
mempty = ReplFlags {
replProgramPaths = mempty,