Commit f0647d6d authored by Herbert Valerio Riedel's avatar Herbert Valerio Riedel 🕺

cabal-install: Define Semigroup instances

This gives `cabal-install` the same treatment as
f6428740 did for `Cabal`
parent 1f698404
......@@ -37,6 +37,7 @@ module Distribution.Client.ComponentDeps (
import Data.Map (Map)
import qualified Data.Map as Map
import Distribution.Compat.Binary (Binary)
import Distribution.Compat.Semigroup (Semigroup((<>)))
import GHC.Generics
import Data.Foldable (fold)
......@@ -72,11 +73,13 @@ type ComponentDep a = (Component, a)
newtype ComponentDeps a = ComponentDeps { unComponentDeps :: Map Component a }
deriving (Show, Functor, Eq, Ord, Generic)
instance Monoid a => Monoid (ComponentDeps a) where
mempty =
ComponentDeps Map.empty
(ComponentDeps d) `mappend` (ComponentDeps d') =
ComponentDeps (Map.unionWith mappend d d')
instance (Semigroup a, Monoid a) => Monoid (ComponentDeps a) where
mempty = ComponentDeps Map.empty
mappend = (<>)
instance Semigroup a => Semigroup (ComponentDeps a) where
ComponentDeps d <> ComponentDeps d' =
ComponentDeps (Map.unionWith (<>) d d')
instance Foldable ComponentDeps where
foldMap f = foldMap f . unComponentDeps
......
......@@ -108,6 +108,8 @@ 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
......@@ -166,7 +168,10 @@ instance Monoid SavedConfig where
savedReportFlags = mempty,
savedHaddockFlags = mempty
}
mappend a b = SavedConfig {
mappend = (<>)
instance Semigroup SavedConfig where
a <> b = SavedConfig {
savedGlobalFlags = combinedSavedGlobalFlags,
savedInstallFlags = combinedSavedInstallFlags,
savedConfigureFlags = combinedSavedConfigureFlags,
......
......@@ -260,7 +260,7 @@ foldProgress step fail done = fold
fold (Done r) = done r
instance Monad (Progress step fail) where
return a = Done a
return = pure
p >>= f = foldProgress Step Fail f p
instance Applicative (Progress step fail) where
......
......@@ -13,6 +13,8 @@ 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
......@@ -108,7 +110,10 @@ instance Monoid GlobalFlags where
globalIgnoreExpiry = mempty,
globalHttpTransport = mempty
}
mappend a b = GlobalFlags {
mappend = (<>)
instance Semigroup GlobalFlags where
a <> b = GlobalFlags {
globalVersion = combine globalVersion,
globalNumericVersion = combine globalNumericVersion,
globalConfigFile = combine globalConfigFile,
......
......@@ -17,6 +17,7 @@ module Distribution.Client.Init.Types where
import Distribution.Simple.Setup
( Flag(..) )
import Distribution.Compat.Semigroup (Semigroup((<>)))
import Distribution.Version
import Distribution.Verbosity
import qualified Distribution.Package as P
......@@ -29,7 +30,7 @@ import qualified Distribution.Compat.ReadP as Parse
import Distribution.Text
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid
import Data.Monoid (Monoid(..))
#endif
-- | InitFlags is really just a simple type to represent certain
......@@ -113,7 +114,10 @@ instance Monoid InitFlags where
, initVerbosity = mempty
, overwrite = mempty
}
mappend a b = InitFlags
mappend = (<>)
instance Semigroup InitFlags where
a <> b = InitFlags
{ nonInteractive = combine nonInteractive
, quiet = combine quiet
, packageDir = combine packageDir
......@@ -141,7 +145,7 @@ instance Monoid InitFlags where
, initVerbosity = combine initVerbosity
, overwrite = combine overwrite
}
where combine field = field a `mappend` field b
where combine field = field a <> field b
-- | Some common package categories.
data Category
......
......@@ -57,6 +57,7 @@ import Data.Monoid (Monoid(..))
import Data.Maybe (isJust, fromMaybe)
import GHC.Generics (Generic)
import Distribution.Compat.Binary (Binary)
import Distribution.Compat.Semigroup (Semigroup((<>)))
import Distribution.Package
( PackageName(..), PackageIdentifier(..)
......@@ -84,9 +85,12 @@ newtype PackageIndex pkg = PackageIndex
deriving (Eq, Show, Read, Functor, Generic)
--FIXME: the Functor instance here relies on no package id changes
instance Package pkg => Semigroup (PackageIndex pkg) where
(<>) = merge
instance Package pkg => Monoid (PackageIndex pkg) where
mempty = PackageIndex Map.empty
mappend = merge
mappend = (<>)
--save one mappend with empty in the common case:
mconcat [] = mempty
mconcat xs = foldr1 mappend xs
......
......@@ -65,6 +65,7 @@ import Data.Maybe ( isJust )
import Data.Monoid ( Monoid(..) )
#endif
import Distribution.Compat.Exception ( catchIO )
import Distribution.Compat.Semigroup ( Semigroup((<>)) )
import System.Directory ( doesDirectoryExist, doesFileExist
, renameFile )
import System.FilePath ( (<.>), (</>), takeDirectory )
......@@ -95,8 +96,10 @@ instance Monoid PackageEnvironment where
pkgEnvInherit = mempty,
pkgEnvSavedConfig = mempty
}
mappend = (<>)
mappend a b = PackageEnvironment {
instance Semigroup PackageEnvironment where
a <> b = PackageEnvironment {
pkgEnvInherit = combine pkgEnvInherit,
pkgEnvSavedConfig = combine pkgEnvSavedConfig
}
......
......@@ -15,9 +15,10 @@ module Distribution.Client.Sandbox.Types (
import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex
import Distribution.Client.Types (SourcePackage)
import Distribution.Compat.Semigroup (Semigroup((<>)))
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid
import Data.Monoid (Monoid(..))
#endif
import qualified Data.Set as S
......@@ -26,10 +27,12 @@ data UseSandbox = UseSandbox FilePath | NoSandbox
instance Monoid UseSandbox where
mempty = NoSandbox
mappend = (<>)
NoSandbox `mappend` s = s
u0@(UseSandbox _) `mappend` NoSandbox = u0
(UseSandbox _) `mappend` u1@(UseSandbox _) = u1
instance Semigroup UseSandbox where
NoSandbox <> s = s
u0@(UseSandbox _) <> NoSandbox = u0
(UseSandbox _) <> u1@(UseSandbox _) = u1
-- | Convert a @UseSandbox@ value to a boolean. Useful in conjunction with
-- @when@.
......
......@@ -95,6 +95,8 @@ import Distribution.ReadE
( ReadE(..), readP_to_E, succeedReadE )
import qualified Distribution.Compat.ReadP as Parse
( ReadP, readP_to_S, readS_to_P, char, munch1, pfail, sepBy1, (+++) )
import Distribution.Compat.Semigroup
( Semigroup((<>)) )
import Distribution.Verbosity
( Verbosity, normal )
import Distribution.Simple.Utils
......@@ -485,7 +487,10 @@ instance Monoid ConfigExFlags where
configSolver = mempty,
configAllowNewer = mempty
}
mappend a b = ConfigExFlags {
mappend = (<>)
instance Semigroup ConfigExFlags where
a <> b = ConfigExFlags {
configCabalVersion = combine configCabalVersion,
configExConstraints= combine configExConstraints,
configPreferences = combine configPreferences,
......@@ -534,7 +539,10 @@ instance Monoid BuildExFlags where
mempty = BuildExFlags {
buildOnly = mempty
}
mappend a b = BuildExFlags {
mappend = (<>)
instance Semigroup BuildExFlags where
a <> b = BuildExFlags {
buildOnly = combine buildOnly
}
where combine field = field a `mappend` field b
......@@ -933,7 +941,10 @@ instance Monoid ReportFlags where
reportPassword = mempty,
reportVerbosity = mempty
}
mappend a b = ReportFlags {
mappend = (<>)
instance Semigroup ReportFlags where
a <> b = ReportFlags {
reportUsername = combine reportUsername,
reportPassword = combine reportPassword,
reportVerbosity = combine reportVerbosity
......@@ -1014,7 +1025,10 @@ instance Monoid GetFlags where
getSourceRepository = mempty,
getVerbosity = mempty
}
mappend a b = GetFlags {
mappend = (<>)
instance Semigroup GetFlags where
a <> b = GetFlags {
getDestDir = combine getDestDir,
getPristine = combine getPristine,
getSourceRepository = combine getSourceRepository,
......@@ -1093,7 +1107,10 @@ instance Monoid ListFlags where
listVerbosity = mempty,
listPackageDBs = mempty
}
mappend a b = ListFlags {
mappend = (<>)
instance Semigroup ListFlags where
a <> b = ListFlags {
listInstalled = combine listInstalled,
listSimpleOutput = combine listSimpleOutput,
listVerbosity = combine listVerbosity,
......@@ -1149,7 +1166,10 @@ instance Monoid InfoFlags where
infoVerbosity = mempty,
infoPackageDBs = mempty
}
mappend a b = InfoFlags {
mappend = (<>)
instance Semigroup InfoFlags where
a <> b = InfoFlags {
infoVerbosity = combine infoVerbosity,
infoPackageDBs = combine infoPackageDBs
}
......@@ -1485,7 +1505,10 @@ instance Monoid InstallFlags where
installRunTests = mempty,
installOfflineMode = mempty
}
mappend a b = InstallFlags {
mappend = (<>)
instance Semigroup InstallFlags where
a <> b = InstallFlags {
installDocumentation = combine installDocumentation,
installHaddockIndex = combine installHaddockIndex,
installDryRun = combine installDryRun,
......@@ -1588,7 +1611,10 @@ instance Monoid UploadFlags where
uploadPasswordCmd = mempty,
uploadVerbosity = mempty
}
mappend a b = UploadFlags {
mappend = (<>)
instance Semigroup UploadFlags where
a <> b = UploadFlags {
uploadCheck = combine uploadCheck,
uploadDoc = combine uploadDoc,
uploadUsername = combine uploadUsername,
......@@ -1829,7 +1855,10 @@ instance Monoid SDistExFlags where
mempty = SDistExFlags {
sDistFormat = mempty
}
mappend a b = SDistExFlags {
mappend = (<>)
instance Semigroup SDistExFlags where
a <> b = SDistExFlags {
sDistFormat = combine sDistFormat
}
where
......@@ -1867,7 +1896,10 @@ instance Monoid Win32SelfUpgradeFlags where
mempty = Win32SelfUpgradeFlags {
win32SelfUpgradeVerbosity = mempty
}
mappend a b = Win32SelfUpgradeFlags {
mappend = (<>)
instance Semigroup Win32SelfUpgradeFlags where
a <> b = Win32SelfUpgradeFlags {
win32SelfUpgradeVerbosity = combine win32SelfUpgradeVerbosity
}
where combine field = field a `mappend` field b
......@@ -1908,7 +1940,10 @@ instance Monoid ActAsSetupFlags where
mempty = ActAsSetupFlags {
actAsSetupBuildType = mempty
}
mappend a b = ActAsSetupFlags {
mappend = (<>)
instance Semigroup ActAsSetupFlags where
a <> b = ActAsSetupFlags {
actAsSetupBuildType = combine actAsSetupBuildType
}
where combine field = field a `mappend` field b
......@@ -2034,7 +2069,10 @@ instance Monoid SandboxFlags where
sandboxSnapshot = mempty,
sandboxLocation = mempty
}
mappend a b = SandboxFlags {
mappend = (<>)
instance Semigroup SandboxFlags where
a <> b = SandboxFlags {
sandboxVerbosity = combine sandboxVerbosity,
sandboxSnapshot = combine sandboxSnapshot,
sandboxLocation = combine sandboxLocation
......@@ -2102,7 +2140,10 @@ instance Monoid ExecFlags where
mempty = ExecFlags {
execVerbosity = mempty
}
mappend a b = ExecFlags {
mappend = (<>)
instance Semigroup ExecFlags where
a <> b = ExecFlags {
execVerbosity = combine execVerbosity
}
where combine field = field a `mappend` field b
......@@ -2121,7 +2162,10 @@ instance Monoid UserConfigFlags where
userConfigVerbosity = toFlag normal,
userConfigForce = toFlag False
}
mappend a b = UserConfigFlags {
mappend = (<>)
instance Semigroup UserConfigFlags where
a <> b = UserConfigFlags {
userConfigVerbosity = combine userConfigVerbosity,
userConfigForce = combine userConfigForce
}
......
......@@ -100,6 +100,8 @@ import Control.Monad (liftM)
import qualified Distribution.Compat.ReadP as Parse
import Distribution.Compat.ReadP
( (+++), (<++) )
import qualified Distribution.Compat.Semigroup as Semi
( Semigroup((<>)) )
import qualified Text.PrettyPrint as Disp
import Text.PrettyPrint
( (<>), (<+>) )
......@@ -675,7 +677,10 @@ newtype PackageNameEnv = PackageNameEnv (PackageName -> [PackageName])
instance Monoid PackageNameEnv where
mempty = PackageNameEnv (const [])
mappend (PackageNameEnv lookupA) (PackageNameEnv lookupB) =
mappend = (Semi.<>)
instance Semi.Semigroup PackageNameEnv where
PackageNameEnv lookupA <> PackageNameEnv lookupB =
PackageNameEnv (\name -> lookupA name ++ lookupB name)
indexPackageNameEnv :: PackageIndex pkg -> PackageNameEnv
......
......@@ -112,6 +112,9 @@ Flag network-uri
executable cabal
main-is: Main.hs
ghc-options: -Wall -fwarn-tabs
if impl(ghc >= 8.0)
ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances
other-modules:
Distribution.Client.BuildReports.Anonymous
Distribution.Client.BuildReports.Storage
......
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