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

Define semigroup instances

This makes the code `-Wcompat`-clean with GHC 8.0

Due to the amount of `Monoid` instances, a compat-layer is used
rather than flooding the code-base with CPP conditionals.
parent a0192ee7
......@@ -253,6 +253,7 @@ library
other-modules:
Distribution.Compat.Binary
Distribution.Compat.CopyFile
Distribution.Compat.Semigroup
Distribution.GetOpt
Distribution.Lex
Distribution.Simple.GHC.Internal
......
{-# LANGUAGE CPP #-}
-- | Compatibility layer for "Data.Semigroup"
module Distribution.Compat.Semigroup
( Semigroup((<>))
, Mon.Monoid(..)
, All(..)
, Any(..)
) where
#if __GLASGOW_HASKELL__ >= 711
-- Data.Semigroup is available since GHC 8.0/base-4.9
import Data.Semigroup
import qualified Data.Monoid as Mon
#else
-- provide internal simplified non-exposed class for older GHCs
import Data.Monoid as Mon (Monoid(..), All(..), Any(..), Dual(..))
class Semigroup a where
(<>) :: a -> a -> a
-- several primitive instances
instance Semigroup () where
_ <> _ = ()
instance Semigroup [a] where
(<>) = (++)
instance Semigroup a => Semigroup (Dual a) where
Dual a <> Dual b = Dual (b <> a)
instance Semigroup a => Semigroup (Maybe a) where
Nothing <> b = b
a <> Nothing = a
Just a <> Just b = Just (a <> b)
instance Semigroup (Either a b) where
Left _ <> b = b
a <> _ = a
instance Semigroup Ordering where
LT <> _ = LT
EQ <> y = y
GT <> _ = GT
instance Semigroup b => Semigroup (a -> b) where
f <> g = \a -> f a <> g a
instance Semigroup All where
All a <> All b = All (a && b)
instance Semigroup Any where
Any a <> Any b = Any (a || b)
instance (Semigroup a, Semigroup b) => Semigroup (a, b) where
(a,b) <> (a',b') = (a<>a',b<>b')
instance (Semigroup a, Semigroup b, Semigroup c)
=> Semigroup (a, b, c) where
(a,b,c) <> (a',b',c') = (a<>a',b<>b',c<>c')
instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d)
=> Semigroup (a, b, c, d) where
(a,b,c,d) <> (a',b',c',d') = (a<>a',b<>b',c<>c',d<>d')
instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d, Semigroup e)
=> Semigroup (a, b, c, d, e) where
(a,b,c,d,e) <> (a',b',c',d',e') = (a<>a',b<>b',c<>c',d<>d',e<>e')
#endif
......@@ -14,7 +14,7 @@ module Distribution.Lex (
) where
import Data.Char (isSpace)
import Data.Monoid as Mon
import Distribution.Compat.Semigroup as Semi
newtype DList a = DList ([a] -> [a])
......@@ -24,9 +24,12 @@ runDList (DList run) = run []
singleton :: a -> DList a
singleton a = DList (a:)
instance Mon.Monoid (DList a) where
instance Monoid (DList a) where
mempty = DList id
DList a `mappend` DList b = DList (a . b)
mappend = (Semi.<>)
instance Semigroup (DList a) where
DList a <> DList b = DList (a . b)
tokenizeQuotedWords :: String -> [String]
tokenizeQuotedWords = filter (not . null) . go False mempty
......
......@@ -110,11 +110,12 @@ module Distribution.PackageDescription (
) where
import Distribution.Compat.Binary (Binary)
import qualified Distribution.Compat.Semigroup as Semi ((<>))
import Distribution.Compat.Semigroup as Semi (Monoid(..), Semigroup)
import Data.Data (Data)
import Data.Foldable (traverse_)
import Data.List (nub, intercalate)
import Data.Maybe (fromMaybe, maybeToList)
import Data.Monoid as Mon (Monoid(..))
import Data.Foldable as Fold (Foldable(foldMap))
import Data.Traversable as Trav (Traversable(traverse))
import Data.Typeable ( Typeable )
......@@ -320,11 +321,12 @@ instance Binary SetupBuildInfo
instance Monoid SetupBuildInfo where
mempty = SetupBuildInfo {
setupDepends = Mon.mempty
}
mappend a b = SetupBuildInfo {
setupDepends = combine setupDepends
setupDepends = Semi.mempty
}
mappend = (Semi.<>)
instance Semigroup SetupBuildInfo where
a <> b = SetupBuildInfo { setupDepends = combine setupDepends }
where combine field = field a `mappend` field b
-- ---------------------------------------------------------------------------
......@@ -348,9 +350,12 @@ lookupRenaming = Map.findWithDefault defaultRenaming . packageName
instance Binary ModuleRenaming where
instance Monoid ModuleRenaming where
ModuleRenaming b rns `mappend` ModuleRenaming b' rns'
= ModuleRenaming (b || b') (rns ++ rns') -- ToDo: dedupe?
mempty = ModuleRenaming False []
mappend = (Semi.<>)
instance Semigroup ModuleRenaming where
ModuleRenaming b rns <> ModuleRenaming b' rns'
= ModuleRenaming (b || b') (rns ++ rns') -- ToDo: dedupe?
-- NB: parentheses are mandatory, because later we may extend this syntax
-- to allow "hiding (A, B)" or other modifier words.
......@@ -410,7 +415,10 @@ instance Monoid Library where
libExposed = True,
libBuildInfo = mempty
}
mappend a b = Library {
mappend = (Semi.<>)
instance Semigroup Library where
a <> b = Library {
exposedModules = combine exposedModules,
reexportedModules = combine reexportedModules,
requiredSignatures = combine requiredSignatures,
......@@ -500,7 +508,10 @@ instance Monoid Executable where
modulePath = mempty,
buildInfo = mempty
}
mappend a b = Executable{
mappend = (Semi.<>)
instance Semigroup Executable where
a <> b = Executable{
exeName = combine' exeName,
modulePath = combine modulePath,
buildInfo = combine buildInfo
......@@ -585,8 +596,10 @@ instance Monoid TestSuite where
testBuildInfo = mempty,
testEnabled = False
}
mappend = (Semi.<>)
mappend a b = TestSuite {
instance Semigroup TestSuite where
a <> b = TestSuite {
testName = combine' testName,
testInterface = combine testInterface,
testBuildInfo = combine testBuildInfo,
......@@ -601,8 +614,11 @@ instance Monoid TestSuite where
instance Monoid TestSuiteInterface where
mempty = TestSuiteUnsupported (TestTypeUnknown mempty (Version [] []))
mappend a (TestSuiteUnsupported _) = a
mappend _ b = b
mappend = (Semi.<>)
instance Semigroup TestSuiteInterface where
a <> (TestSuiteUnsupported _) = a
_ <> b = b
emptyTestSuite :: TestSuite
emptyTestSuite = mempty
......@@ -718,8 +734,10 @@ instance Monoid Benchmark where
benchmarkBuildInfo = mempty,
benchmarkEnabled = False
}
mappend = (Semi.<>)
mappend a b = Benchmark {
instance Semigroup Benchmark where
a <> b = Benchmark {
benchmarkName = combine' benchmarkName,
benchmarkInterface = combine benchmarkInterface,
benchmarkBuildInfo = combine benchmarkBuildInfo,
......@@ -734,8 +752,11 @@ instance Monoid Benchmark where
instance Monoid BenchmarkInterface where
mempty = BenchmarkUnsupported (BenchmarkTypeUnknown mempty (Version [] []))
mappend a (BenchmarkUnsupported _) = a
mappend _ b = b
mappend = (Semi.<>)
instance Semigroup BenchmarkInterface where
a <> (BenchmarkUnsupported _) = a
_ <> b = b
emptyBenchmark :: Benchmark
emptyBenchmark = mempty
......@@ -857,7 +878,10 @@ instance Monoid BuildInfo where
targetBuildDepends = [],
targetBuildRenaming = Map.empty
}
mappend a b = BuildInfo {
mappend = (Semi.<>)
instance Semigroup BuildInfo where
a <> b = BuildInfo {
buildable = buildable a && buildable b,
buildTools = combine buildTools,
cppOptions = combine cppOptions,
......@@ -1220,7 +1244,10 @@ instance Monad Condition where
instance Monoid (Condition a) where
mempty = Lit False
mappend = COr
mappend = (Semi.<>)
instance Semigroup (Condition a) where
(<>) = COr
instance Alternative Condition where
empty = mempty
......
......@@ -54,12 +54,12 @@ import Distribution.Text
import Distribution.Compat.ReadP as ReadP hiding ( char )
import Control.Arrow (first)
import qualified Distribution.Compat.ReadP as ReadP ( char )
import Distribution.Compat.Semigroup as Semi
import Data.Char ( isAlphaNum )
import Data.Maybe ( mapMaybe, maybeToList )
import Data.Map ( Map, fromListWith, toList )
import qualified Data.Map as Map
import Data.Monoid as Mon
------------------------------------------------------------------------------
......@@ -182,12 +182,14 @@ mapTreeData f = mapCondTree f id id
-- clarity.
data DepTestRslt d = DepOk | MissingDeps d
instance Monoid d => Mon.Monoid (DepTestRslt d) where
instance Semigroup d => Monoid (DepTestRslt d) where
mempty = DepOk
mappend DepOk x = x
mappend x DepOk = x
mappend (MissingDeps d) (MissingDeps d') = MissingDeps (d `mappend` d')
mappend = (Semi.<>)
instance Semigroup d => Semigroup (DepTestRslt d) where
DepOk <> x = x
x <> DepOk = x
(MissingDeps d) <> (MissingDeps d') = MissingDeps (d <> d')
data BT a = BTN a | BTB (BT a) (BT a) -- very simple binary tree
......@@ -291,7 +293,10 @@ newtype DependencyMap = DependencyMap { unDependencyMap :: Map PackageName Versi
instance Monoid DependencyMap where
mempty = DependencyMap Map.empty
(DependencyMap a) `mappend` (DependencyMap b) =
mappend = (Semi.<>)
instance Semigroup DependencyMap where
(DependencyMap a) <> (DependencyMap b) =
DependencyMap (Map.unionWith intersectVersionRanges a b)
toDepMap :: [Dependency] -> DependencyMap
......@@ -437,13 +442,16 @@ data PDTagged = Lib Library
instance Monoid PDTagged where
mempty = PDNull
PDNull `mappend` x = x
x `mappend` PDNull = x
Lib l `mappend` Lib l' = Lib (l `mappend` l')
Exe n e `mappend` Exe n' e' | n == n' = Exe n (e `mappend` e')
Test n t `mappend` Test n' t' | n == n' = Test n (t `mappend` t')
Bench n b `mappend` Bench n' b' | n == n' = Bench n (b `mappend` b')
_ `mappend` _ = cabalBug "Cannot combine incompatible tags"
mappend = (Semi.<>)
instance Semigroup PDTagged where
PDNull <> x = x
x <> PDNull = x
Lib l <> Lib l' = Lib (l <> l')
Exe n e <> Exe n' e' | n == n' = Exe n (e <> e')
Test n t <> Test n' t' | n == n' = Test n (t <> t')
Bench n b <> Bench n' b' | n == n' = Bench n (b <> b')
_ <> _ = cabalBug "Cannot combine incompatible tags"
-- | Create a package description with all configurations resolved.
--
......
......@@ -46,8 +46,7 @@ module Distribution.Simple.CCompiler (
filenameCDialect
) where
import Data.Monoid as Mon
( Monoid(..) )
import Distribution.Compat.Semigroup as Semi
import System.FilePath
( takeExtension )
......@@ -62,17 +61,18 @@ data CDialect = C
| ObjectiveCPlusPlus
deriving (Eq, Show)
instance Mon.Monoid CDialect where
instance Monoid CDialect where
mempty = C
mappend C anything = anything
mappend ObjectiveC CPlusPlus = ObjectiveCPlusPlus
mappend CPlusPlus ObjectiveC = ObjectiveCPlusPlus
mappend _ ObjectiveCPlusPlus = ObjectiveCPlusPlus
mappend ObjectiveC _ = ObjectiveC
mappend CPlusPlus _ = CPlusPlus
mappend ObjectiveCPlusPlus _ = ObjectiveCPlusPlus
mappend = (Semi.<>)
instance Semigroup CDialect where
C <> anything = anything
ObjectiveC <> CPlusPlus = ObjectiveCPlusPlus
CPlusPlus <> ObjectiveC = ObjectiveCPlusPlus
_ <> ObjectiveCPlusPlus = ObjectiveCPlusPlus
ObjectiveC <> _ = ObjectiveC
CPlusPlus <> _ = CPlusPlus
ObjectiveCPlusPlus <> _ = ObjectiveCPlusPlus
-- | A list of all file extensions which are recognized as possibly containing
-- some dialect of C code. Note that this list is only for source files,
......
......@@ -24,6 +24,7 @@ import qualified Distribution.Simple.GHC as GHC
import qualified Distribution.Simple.GHCJS as GHCJS
-- local
import Distribution.Compat.Semigroup as Semi
import Distribution.Package
( PackageIdentifier(..)
, Package(..)
......@@ -86,7 +87,6 @@ import Language.Haskell.Extension
import Control.Monad ( when, forM_ )
import Data.Either ( rights )
import Data.Foldable ( traverse_ )
import Data.Monoid
import Data.Maybe ( fromMaybe, listToMaybe )
import System.Directory (doesFileExist)
......@@ -794,7 +794,10 @@ instance Monoid HaddockArgs where
argGhcLibDir = mempty,
argTargets = mempty
}
mappend a b = HaddockArgs {
mappend = (Semi.<>)
instance Semigroup HaddockArgs where
a <> b = HaddockArgs {
argInterfaceFile = mult argInterfaceFile,
argPackageName = mult argPackageName,
argHideModules = mult argHideModules,
......@@ -816,4 +819,7 @@ instance Monoid HaddockArgs where
instance Monoid Directory where
mempty = Dir "."
mappend (Dir m) (Dir n) = Dir $ m </> n
mappend = (Semi.<>)
instance Semigroup Directory where
Dir m <> Dir n = Dir $ m </> n
......@@ -46,11 +46,9 @@ module Distribution.Simple.InstallDirs (
import Distribution.Compat.Binary (Binary)
import Distribution.Compat.Semigroup as Semi
import Data.List (isPrefixOf)
import Data.Maybe (fromMaybe)
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid (Monoid(..))
#endif
import GHC.Generics (Generic)
import System.Directory (getAppUserDataDirectory)
import System.FilePath ((</>), isPathSeparator, pathSeparator)
......@@ -118,7 +116,7 @@ instance Functor InstallDirs where
sysconfdir = f (sysconfdir dirs)
}
instance Monoid dir => Monoid (InstallDirs dir) where
instance (Semigroup dir, Monoid dir) => Monoid (InstallDirs dir) where
mempty = InstallDirs {
prefix = mempty,
bindir = mempty,
......@@ -135,7 +133,10 @@ instance Monoid dir => Monoid (InstallDirs dir) where
haddockdir = mempty,
sysconfdir = mempty
}
mappend = combineInstallDirs mappend
mappend = (Semi.<>)
instance Semigroup dir => Semigroup (InstallDirs dir) where
(<>) = combineInstallDirs (<>)
combineInstallDirs :: (a -> b -> c)
-> InstallDirs a
......
......@@ -65,11 +65,11 @@ import Control.Exception (assert)
import Data.Array ((!))
import qualified Data.Array as Array
import Distribution.Compat.Binary (Binary)
import Distribution.Compat.Semigroup as Semi
import qualified Data.Graph as Graph
import Data.List as List
( null, foldl', sort
, groupBy, sortBy, find, isInfixOf, nubBy, deleteBy, deleteFirstsBy )
import Data.Monoid as Mon (Monoid(..))
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (isNothing, fromMaybe)
......@@ -127,11 +127,14 @@ type InstalledPackageIndex = PackageIndex InstalledPackageInfo
instance HasComponentId a => Monoid (PackageIndex a) where
mempty = PackageIndex Map.empty Map.empty
mappend = merge
mappend = (Semi.<>)
--save one mappend with empty in the common case:
mconcat [] = Mon.mempty
mconcat [] = mempty
mconcat xs = foldr1 mappend xs
instance HasComponentId a => Semigroup (PackageIndex a) where
(<>) = merge
invariant :: HasComponentId a => PackageIndex a -> Bool
invariant (PackageIndex pids pnames) =
map installedComponentId (Map.elems pids)
......
......@@ -12,6 +12,7 @@ module Distribution.Simple.Program.GHC (
) where
import Distribution.Compat.Semigroup as Semi
import Distribution.Simple.GHC.ImplInfo ( getImplInfo, GhcImplInfo(..) )
import Distribution.Package
import Distribution.PackageDescription hiding (Flag)
......@@ -27,7 +28,6 @@ import Distribution.Utils.NubList ( NubListR, fromNubListR )
import Language.Haskell.Extension ( Language(..), Extension(..) )
import qualified Data.Map as M
import Data.Monoid as Mon
import Data.List ( intercalate )
-- | A structured set of GHC options/flags
......@@ -491,7 +491,7 @@ packageDbArgs implInfo
instance Monoid GhcOptions where
mempty = GhcOptions {
ghcOptMode = Mon.mempty,
ghcOptMode = mempty,
ghcOptExtra = mempty,
ghcOptExtraDefault = mempty,
ghcOptInputFiles = mempty,
......@@ -544,7 +544,10 @@ instance Monoid GhcOptions where
ghcOptVerbosity = mempty,
ghcOptCabal = mempty
}
mappend a b = GhcOptions {
mappend = (Semi.<>)
instance Semigroup GhcOptions where
a <> b = GhcOptions {
ghcOptMode = combine ghcOptMode,
ghcOptExtra = combine ghcOptExtra,
ghcOptExtraDefault = combine ghcOptExtraDefault,
......
......@@ -102,11 +102,9 @@ import Distribution.Utils.NubList
import Control.Monad (liftM)
import Distribution.Compat.Binary (Binary)
import Distribution.Compat.Semigroup as Semi
import Data.List ( sort )
import Data.Char ( isSpace, isAlpha )
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid ( Monoid(..) )
#endif
import GHC.Generics (Generic)
-- FIXME Not sure where this should live
......@@ -144,8 +142,11 @@ instance Functor Flag where
instance Monoid (Flag a) where
mempty = NoFlag
_ `mappend` f@(Flag _) = f
f `mappend` NoFlag = f
mappend = (Semi.<>)
instance Semigroup (Flag a) where
_ <> f@(Flag _) = f
f <> NoFlag = f
instance Bounded a => Bounded (Flag a) where
minBound = toFlag minBound
......@@ -256,7 +257,10 @@ instance Monoid GlobalFlags where
globalVersion = mempty,
globalNumericVersion = mempty
}
mappend a b = GlobalFlags {
mappend = (Semi.<>)
instance Semigroup GlobalFlags where
a <> b = GlobalFlags {
globalVersion = combine globalVersion,
globalNumericVersion = combine globalNumericVersion
}
......@@ -803,7 +807,10 @@ instance Monoid ConfigFlags where
configRelocatable = mempty,
configDebugInfo = mempty
}
mappend a b = ConfigFlags {
mappend = (Semi.<>)
instance Semigroup ConfigFlags where
a <> b = ConfigFlags {
configPrograms = configPrograms b,
configProgramPaths = combine configProgramPaths,
configProgramArgs = combine configProgramArgs,
......@@ -905,7 +912,10 @@ instance Monoid CopyFlags where
copyDistPref = mempty,
copyVerbosity = mempty
}
mappend a b = CopyFlags {
mappend = (Semi.<>)
instance Semigroup CopyFlags where
a <> b = CopyFlags {
copyDest = combine copyDest,
copyDistPref = combine copyDistPref,
copyVerbosity = combine copyVerbosity
......@@ -984,7 +994,10 @@ instance Monoid InstallFlags where
installInPlace = mempty,
installVerbosity = mempty
}
mappend a b = InstallFlags{
mappend = (Semi.<>)
instance Semigroup InstallFlags where
a <> b = InstallFlags{
installPackageDB = combine installPackageDB,
installDistPref = combine installDistPref,
installUseWrapper = combine installUseWrapper,
......@@ -1061,7 +1074,10 @@ instance Monoid SDistFlags where
sDistListSources = mempty,
sDistVerbosity = mempty
}
mappend a b = SDistFlags {
mappend = (Semi.<>)
instance Semigroup SDistFlags where
a <> b = SDistFlags {
sDistSnapshot = combine sDistSnapshot,
sDistDirectory = combine sDistDirectory,
sDistDistPref = combine sDistDistPref,
......@@ -1186,7 +1202,10 @@ instance Monoid RegisterFlags where
regDistPref = mempty,
regVerbosity = mempty
}
mappend a b = RegisterFlags {
mappend = (Semi.<>)
instance Semigroup RegisterFlags where
a <> b = RegisterFlags {
regPackageDB = combine regPackageDB,
regGenScript = combine regGenScript,
regGenPkgConf = combine regGenPkgConf,
......@@ -1233,7 +1252,10 @@ instance Monoid HscolourFlags where
hscolourDistPref = mempty,
hscolourVerbosity = mempty
}
mappend a b = HscolourFlags {
mappend = (Semi.<>)
instance Semigroup HscolourFlags where
a <> b = HscolourFlags {
hscolourCSS = combine hscolourCSS,
hscolourExecutables = combine hscolourExecutables,
hscolourTestSuites = combine hscolourTestSuites,
......@@ -1471,7 +1493,10 @@ instance Monoid HaddockFlags where
haddockKeepTempFiles= mempty,
haddockVerbosity = mempty
}
mappend a b = HaddockFlags {
mappend = (Semi.<>)
instance Semigroup HaddockFlags where
a <> b = HaddockFlags {
haddockProgramPaths = combine haddockProgramPaths,
haddockProgramArgs = combine haddockProgramArgs,
haddockHoogle = combine haddockHoogle,
......@@ -1542,7 +1567,10 @@ instance Monoid CleanFlags where
cleanDistPref = mempty,