Commit 3bcae47a authored by Herbert Valerio Riedel's avatar Herbert Valerio Riedel 🕺

Derive some Semigroup/Monoid instances via Generics (cabal-install)

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.

While at it, this removes -XCPP usage from all modules touched.

This addresses #3169
parent ec6dd74d
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
-----------------------------------------------------------------------------
......@@ -102,16 +101,11 @@ import Data.List
( partition, find, foldl' )
import Data.Maybe
( fromMaybe )
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid
( Monoid(..) )
#endif
import Control.Monad
( when, unless, foldM, liftM, liftM2 )
import qualified Distribution.Compat.ReadP as Parse
( (<++), option )
import Distribution.Compat.Semigroup
( Semigroup((<>)) )
import qualified Text.PrettyPrint as Disp
( render, text, empty )
import Text.PrettyPrint
......@@ -160,17 +154,7 @@ data SavedConfig = SavedConfig {
} deriving Generic
instance Monoid SavedConfig where
mempty = SavedConfig {
savedGlobalFlags = mempty,
savedInstallFlags = mempty,
savedConfigureFlags = mempty,
savedConfigureExFlags = mempty,
savedUserInstallDirs = mempty,
savedGlobalInstallDirs = mempty,
savedUploadFlags = mempty,
savedReportFlags = mempty,
savedHaddockFlags = mempty
}
mempty = gmempty
mappend = (<>)
instance Semigroup SavedConfig where
......
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RankNTypes #-}
......@@ -15,7 +14,6 @@ module Distribution.Client.GlobalFlags (
import Distribution.Client.Types
( Repo(..), RemoteRepo(..) )
import Distribution.Compat.Semigroup
( Semigroup((<>)) )
import Distribution.Simple.Setup
( Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe )
import Distribution.Utils.NubList
......@@ -40,11 +38,6 @@ import Network.URI
import Data.Map
( Map )
import qualified Data.Map as Map
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid
( Monoid(..) )
#endif
import GHC.Generics ( Generic )
import qualified Hackage.Security.Client as Sec
......@@ -96,42 +89,11 @@ defaultGlobalFlags = GlobalFlags {
}
instance Monoid GlobalFlags where
mempty = GlobalFlags {
globalVersion = mempty,
globalNumericVersion = mempty,
globalConfigFile = mempty,
globalSandboxConfigFile = mempty,
globalConstraintsFile = mempty,
globalRemoteRepos = mempty,
globalCacheDir = mempty,
globalLocalRepos = mempty,
globalLogsDir = mempty,
globalWorldFile = mempty,
globalRequireSandbox = mempty,
globalIgnoreSandbox = mempty,
globalIgnoreExpiry = mempty,
globalHttpTransport = mempty
}
mempty = gmempty
mappend = (<>)
instance Semigroup GlobalFlags where
a <> b = GlobalFlags {
globalVersion = combine globalVersion,
globalNumericVersion = combine globalNumericVersion,
globalConfigFile = combine globalConfigFile,
globalSandboxConfigFile = combine globalConfigFile,
globalConstraintsFile = combine globalConstraintsFile,
globalRemoteRepos = combine globalRemoteRepos,
globalCacheDir = combine globalCacheDir,
globalLocalRepos = combine globalLocalRepos,
globalLogsDir = combine globalLogsDir,
globalWorldFile = combine globalWorldFile,
globalRequireSandbox = combine globalRequireSandbox,
globalIgnoreSandbox = combine globalIgnoreSandbox,
globalIgnoreExpiry = combine globalIgnoreExpiry,
globalHttpTransport = combine globalHttpTransport
}
where combine field = field a `mappend` field b
(<>) = gmappend
-- ------------------------------------------------------------
-- * Repo context
......
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
-----------------------------------------------------------------------------
......@@ -19,7 +18,7 @@ module Distribution.Client.Init.Types where
import Distribution.Simple.Setup
( Flag(..) )
import Distribution.Compat.Semigroup (Semigroup((<>)))
import Distribution.Compat.Semigroup
import Distribution.Version
import Distribution.Verbosity
import qualified Distribution.Package as P
......@@ -31,10 +30,7 @@ import qualified Text.PrettyPrint as Disp
import qualified Distribution.Compat.ReadP as Parse
import Distribution.Text
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (Monoid(..))
#endif
import GHC.Generics (Generic)
import GHC.Generics ( Generic )
-- | InitFlags is really just a simple type to represent certain
-- portions of a .cabal file. Rather than have a flag for EVERY
......@@ -89,66 +85,11 @@ instance Text PackageType where
parse = Parse.choice $ map (fmap read . Parse.string . show) [Library, Executable]
instance Monoid InitFlags where
mempty = InitFlags
{ nonInteractive = mempty
, quiet = mempty
, packageDir = mempty
, noComments = mempty
, minimal = mempty
, packageName = mempty
, version = mempty
, cabalVersion = mempty
, license = mempty
, author = mempty
, email = mempty
, homepage = mempty
, synopsis = mempty
, category = mempty
, extraSrc = mempty
, packageType = mempty
, mainIs = mempty
, language = mempty
, exposedModules = mempty
, otherModules = mempty
, otherExts = mempty
, dependencies = mempty
, sourceDirs = mempty
, buildTools = mempty
, initVerbosity = mempty
, overwrite = mempty
}
mempty = gmempty
mappend = (<>)
instance Semigroup InitFlags where
a <> b = InitFlags
{ nonInteractive = combine nonInteractive
, quiet = combine quiet
, packageDir = combine packageDir
, noComments = combine noComments
, minimal = combine minimal
, packageName = combine packageName
, version = combine version
, cabalVersion = combine cabalVersion
, license = combine license
, author = combine author
, email = combine email
, homepage = combine homepage
, synopsis = combine synopsis
, category = combine category
, extraSrc = combine extraSrc
, packageType = combine packageType
, mainIs = combine mainIs
, language = combine language
, exposedModules = combine exposedModules
, otherModules = combine otherModules
, otherExts = combine otherExts
, dependencies = combine dependencies
, sourceDirs = combine sourceDirs
, buildTools = combine buildTools
, initVerbosity = combine initVerbosity
, overwrite = combine overwrite
}
where combine field = field a <> field b
(<>) = gmappend
-- | Some common package categories.
data Category
......
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
-----------------------------------------------------------------------------
......@@ -63,11 +62,8 @@ import Distribution.Verbosity ( Verbosity, normal )
import Control.Monad ( foldM, liftM2, when, unless )
import Data.List ( partition )
import Data.Maybe ( isJust )
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid ( Monoid(..) )
#endif
import Distribution.Compat.Exception ( catchIO )
import Distribution.Compat.Semigroup ( Semigroup((<>)) )
import Distribution.Compat.Semigroup
import System.Directory ( doesDirectoryExist, doesFileExist
, renameFile )
import System.FilePath ( (<.>), (</>), takeDirectory )
......@@ -95,19 +91,11 @@ data PackageEnvironment = PackageEnvironment {
} deriving Generic
instance Monoid PackageEnvironment where
mempty = PackageEnvironment {
pkgEnvInherit = mempty,
pkgEnvSavedConfig = mempty
}
mempty = gmempty
mappend = (<>)
instance Semigroup PackageEnvironment where
a <> b = PackageEnvironment {
pkgEnvInherit = combine pkgEnvInherit,
pkgEnvSavedConfig = combine pkgEnvSavedConfig
}
where
combine f = f a `mappend` f b
(<>) = gmappend
-- | The automatically-created package environment file that should not be
-- touched by the user.
......
{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RankNTypes #-}
......@@ -97,7 +96,6 @@ import Distribution.ReadE
import qualified Distribution.Compat.ReadP as Parse
( ReadP, char, munch1, pfail, (+++) )
import Distribution.Compat.Semigroup
( Semigroup((<>)) )
import Distribution.Verbosity
( Verbosity, normal )
import Distribution.Simple.Utils
......@@ -113,10 +111,6 @@ import Data.List
( intercalate, deleteFirstsBy )
import Data.Maybe
( maybeToList, fromMaybe )
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid
( Monoid(..) )
#endif
import GHC.Generics (Generic)
import Distribution.Compat.Binary (Binary)
import Control.Monad
......@@ -476,22 +470,11 @@ configureExOptions _showOrParseArgs src =
]
instance Monoid ConfigExFlags where
mempty = ConfigExFlags {
configCabalVersion = mempty,
configExConstraints= mempty,
configPreferences = mempty,
configSolver = mempty
}
mempty = gmempty
mappend = (<>)
instance Semigroup ConfigExFlags where
a <> b = ConfigExFlags {
configCabalVersion = combine configCabalVersion,
configExConstraints= combine configExConstraints,
configPreferences = combine configPreferences,
configSolver = combine configSolver
}
where combine field = field a `mappend` field b
(<>) = gmappend
-- ------------------------------------------------------------
-- * Build flags
......@@ -530,16 +513,11 @@ buildCommand = parent {
parent = Cabal.buildCommand defaultProgramConfiguration
instance Monoid BuildExFlags where
mempty = BuildExFlags {
buildOnly = mempty
}
mempty = gmempty
mappend = (<>)
instance Semigroup BuildExFlags where
a <> b = BuildExFlags {
buildOnly = combine buildOnly
}
where combine field = field a `mappend` field b
(<>) = gmappend
-- ------------------------------------------------------------
-- * Repl command
......@@ -930,20 +908,11 @@ reportCommand = CommandUI {
}
instance Monoid ReportFlags where
mempty = ReportFlags {
reportUsername = mempty,
reportPassword = mempty,
reportVerbosity = mempty
}
mempty = gmempty
mappend = (<>)
instance Semigroup ReportFlags where
a <> b = ReportFlags {
reportUsername = combine reportUsername,
reportPassword = combine reportPassword,
reportVerbosity = combine reportVerbosity
}
where combine field = field a `mappend` field b
(<>) = gmappend
-- ------------------------------------------------------------
-- * Get flags
......@@ -1013,22 +982,11 @@ unpackCommand = getCommand {
}
instance Monoid GetFlags where
mempty = GetFlags {
getDestDir = mempty,
getPristine = mempty,
getSourceRepository = mempty,
getVerbosity = mempty
}
mempty = gmempty
mappend = (<>)
instance Semigroup GetFlags where
a <> b = GetFlags {
getDestDir = combine getDestDir,
getPristine = combine getPristine,
getSourceRepository = combine getSourceRepository,
getVerbosity = combine getVerbosity
}
where combine field = field a `mappend` field b
(<>) = gmappend
-- ------------------------------------------------------------
-- * List flags
......@@ -1095,22 +1053,11 @@ listCommand = CommandUI {
}
instance Monoid ListFlags where
mempty = ListFlags {
listInstalled = mempty,
listSimpleOutput = mempty,
listVerbosity = mempty,
listPackageDBs = mempty
}
mempty = gmempty
mappend = (<>)
instance Semigroup ListFlags where
a <> b = ListFlags {
listInstalled = combine listInstalled,
listSimpleOutput = combine listSimpleOutput,
listVerbosity = combine listVerbosity,
listPackageDBs = combine listPackageDBs
}
where combine field = field a `mappend` field b
(<>) = gmappend
-- ------------------------------------------------------------
-- * Info flags
......@@ -1156,18 +1103,11 @@ infoCommand = CommandUI {
}
instance Monoid InfoFlags where
mempty = InfoFlags {
infoVerbosity = mempty,
infoPackageDBs = mempty
}
mempty = gmempty
mappend = (<>)
instance Semigroup InfoFlags where
a <> b = InfoFlags {
infoVerbosity = combine infoVerbosity,
infoPackageDBs = combine infoPackageDBs
}
where combine field = field a `mappend` field b
(<>) = gmappend
-- ------------------------------------------------------------
-- * Install flags
......@@ -1452,62 +1392,11 @@ installOptions showOrParseArgs =
instance Monoid InstallFlags where
mempty = InstallFlags {
installDocumentation = mempty,
installHaddockIndex = mempty,
installDryRun = mempty,
installReinstall = mempty,
installAvoidReinstalls = mempty,
installOverrideReinstall = mempty,
installMaxBackjumps = mempty,
installUpgradeDeps = mempty,
installReorderGoals = mempty,
installIndependentGoals= mempty,
installShadowPkgs = mempty,
installStrongFlags = mempty,
installOnly = mempty,
installOnlyDeps = mempty,
installRootCmd = mempty,
installSummaryFile = mempty,
installLogFile = mempty,
installBuildReports = mempty,
installReportPlanningFailure = mempty,
installSymlinkBinDir = mempty,
installOneShot = mempty,
installNumJobs = mempty,
installRunTests = mempty,
installOfflineMode = mempty
}
mempty = gmempty
mappend = (<>)
instance Semigroup InstallFlags where
a <> b = InstallFlags {
installDocumentation = combine installDocumentation,
installHaddockIndex = combine installHaddockIndex,
installDryRun = combine installDryRun,
installReinstall = combine installReinstall,
installAvoidReinstalls = combine installAvoidReinstalls,
installOverrideReinstall = combine installOverrideReinstall,
installMaxBackjumps = combine installMaxBackjumps,
installUpgradeDeps = combine installUpgradeDeps,
installReorderGoals = combine installReorderGoals,
installIndependentGoals= combine installIndependentGoals,
installShadowPkgs = combine installShadowPkgs,
installStrongFlags = combine installStrongFlags,
installOnly = combine installOnly,
installOnlyDeps = combine installOnlyDeps,
installRootCmd = combine installRootCmd,
installSummaryFile = combine installSummaryFile,
installLogFile = combine installLogFile,
installBuildReports = combine installBuildReports,
installReportPlanningFailure = combine installReportPlanningFailure,
installSymlinkBinDir = combine installSymlinkBinDir,
installOneShot = combine installOneShot,
installNumJobs = combine installNumJobs,
installRunTests = combine installRunTests,
installOfflineMode = combine installOfflineMode
}
where combine field = field a `mappend` field b
(<>) = gmappend
-- ------------------------------------------------------------
-- * Upload flags
......@@ -1576,26 +1465,11 @@ uploadCommand = CommandUI {
}
instance Monoid UploadFlags where
mempty = UploadFlags {
uploadCheck = mempty,
uploadDoc = mempty,
uploadUsername = mempty,
uploadPassword = mempty,
uploadPasswordCmd = mempty,
uploadVerbosity = mempty
}
mempty = gmempty
mappend = (<>)
instance Semigroup UploadFlags where
a <> b = UploadFlags {
uploadCheck = combine uploadCheck,
uploadDoc = combine uploadDoc,
uploadUsername = combine uploadUsername,
uploadPassword = combine uploadPassword,
uploadPasswordCmd = combine uploadPasswordCmd,
uploadVerbosity = combine uploadVerbosity
}
where combine field = field a `mappend` field b
(<>) = gmappend
-- ------------------------------------------------------------
-- * Init flags
......@@ -1825,17 +1699,11 @@ sdistCommand = Cabal.sdistCommand {
]
instance Monoid SDistExFlags where
mempty = SDistExFlags {
sDistFormat = mempty
}
mempty = gmempty
mappend = (<>)
instance Semigroup SDistExFlags where
a <> b = SDistExFlags {
sDistFormat = combine sDistFormat
}
where
combine field = field a `mappend` field b
(<>) = gmappend
-- ------------------------------------------------------------
-- * Win32SelfUpgrade flags
......@@ -1866,16 +1734,11 @@ win32SelfUpgradeCommand = CommandUI {
}
instance Monoid Win32SelfUpgradeFlags where
mempty = Win32SelfUpgradeFlags {
win32SelfUpgradeVerbosity = mempty
}
mempty = gmempty
mappend = (<>)
instance Semigroup Win32SelfUpgradeFlags where
a <> b = Win32SelfUpgradeFlags {
win32SelfUpgradeVerbosity = combine win32SelfUpgradeVerbosity
}
where combine field = field a `mappend` field b
(<>) = gmappend
-- ------------------------------------------------------------
-- * ActAsSetup flags
......@@ -1910,16 +1773,11 @@ actAsSetupCommand = CommandUI {
}
instance Monoid ActAsSetupFlags where
mempty = ActAsSetupFlags {
actAsSetupBuildType = mempty
}
mempty = gmempty
mappend = (<>)
instance Semigroup ActAsSetupFlags where
a <> b = ActAsSetupFlags {
actAsSetupBuildType = combine actAsSetupBuildType
}
where combine field = field a `mappend` field b
(<>) = gmappend
-- ------------------------------------------------------------
-- * Sandbox-related flags
......@@ -2037,20 +1895,11 @@ sandboxCommand = CommandUI {
}
instance Monoid SandboxFlags where
mempty = SandboxFlags {
sandboxVerbosity = mempty,
sandboxSnapshot = mempty,
sandboxLocation = mempty
}
mempty = gmempty
mappend = (<>)
instance Semigroup SandboxFlags where
a <> b = SandboxFlags {
sandboxVerbosity = combine sandboxVerbosity,
sandboxSnapshot = combine sandboxSnapshot,
sandboxLocation = combine sandboxLocation
}
where combine field = field a `mappend` field b
(<>) = gmappend
-- ------------------------------------------------------------
-- * Exec Flags
......@@ -2110,16 +1959,11 @@ execCommand = CommandUI {
}
instance Monoid ExecFlags where
mempty = ExecFlags {
execVerbosity = mempty
}
mempty = gmempty
mappend = (<>)
instance Semigroup ExecFlags where
a <> b = ExecFlags {
execVerbosity = combine execVerbosity
}
where combine field = field a `mappend` field b
(<>) = gmappend
-- ------------------------------------------------------------
-- * UserConfig flags
......@@ -2128,7 +1972,7 @@ instance Semigroup ExecFlags where
data UserConfigFlags = UserConfigFlags {
userConfigVerbosity :: Flag Verbosity,
userConfigForce :: Flag Bool
}
} deriving Generic
instance Monoid UserConfigFlags where
mempty = UserConfigFlags {
......@@ -2138,11 +1982,7 @@ instance Monoid UserConfigFlags where
mappend = (<>)
instance Semigroup UserConfigFlags where
a <> b = UserConfigFlags {
userConfigVerbosity = combine userConfigVerbosity,
userConfigForce = combine userConfigForce
}
where combine field = field a `mappend` field b
(<>) = gmappend
userConfigCommand :: CommandUI UserConfigFlags
userConfigCommand = CommandUI {
......
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