Skip to content

Replace Boilerplate Monoid/Semigroup instances with generics #3196

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 5 commits into from
Feb 29, 2016
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
17 changes: 5 additions & 12 deletions Cabal/Distribution/PackageDescription.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
44 changes: 6 additions & 38 deletions Cabal/Distribution/Simple/Haddock.hs
Original file line number Diff line number Diff line change
@@ -1,3 +1,5 @@
{-# LANGUAGE DeriveGeneric #-}

-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Simple.Haddock
Expand Down Expand Up @@ -54,6 +56,7 @@ import Data.Char ( isSpace )
import Data.Either ( rights )
import Data.Foldable ( traverse_, foldl' )
import Data.Maybe ( fromMaybe, listToMaybe )
import GHC.Generics ( Generic )

import System.Directory (doesFileExist)
import System.FilePath ( (</>), (<.>)
Expand Down Expand Up @@ -97,7 +100,7 @@ data HaddockArgs = HaddockArgs {
-- ^ To find the correct GHC, required.
argTargets :: [FilePath]
-- ^ Modules to process.
}
} deriving Generic

-- | The FilePath of a directory, it's a monoid under '(</>)'.
newtype Directory = Dir { unDir' :: FilePath } deriving (Read,Show,Eq,Ord)
Expand Down Expand Up @@ -760,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 "."
Expand Down
40 changes: 4 additions & 36 deletions Cabal/Distribution/Simple/InstallDirs.hs
Original file line number Diff line number Diff line change
@@ -1,5 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}

-----------------------------------------------------------------------------
Expand Down Expand Up @@ -90,49 +91,16 @@ data InstallDirs dir = InstallDirs {
htmldir :: dir,
haddockdir :: dir,
sysconfdir :: dir
} deriving (Eq, Read, Show, Generic)
} deriving (Eq, Read, Show, Functor, Generic)

instance Binary dir => Binary (InstallDirs dir)

instance Functor InstallDirs where
fmap f dirs = InstallDirs {
prefix = f (prefix dirs),
bindir = f (bindir dirs),
libdir = f (libdir dirs),
libsubdir = f (libsubdir dirs),
dynlibdir = f (dynlibdir dirs),
libexecdir = f (libexecdir dirs),
includedir = f (includedir dirs),
datadir = f (datadir dirs),
datasubdir = f (datasubdir dirs),
docdir = f (docdir dirs),
mandir = f (mandir dirs),
htmldir = f (htmldir dirs),
haddockdir = f (haddockdir dirs),
sysconfdir = f (sysconfdir dirs)
}

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
Expand Down
117 changes: 6 additions & 111 deletions Cabal/Distribution/Simple/Program/GHC.hs
Original file line number Diff line number Diff line change
@@ -1,3 +1,5 @@
{-# LANGUAGE DeriveGeneric #-}

module Distribution.Simple.Program.GHC (
GhcOptions(..),
GhcMode(..),
Expand Down Expand Up @@ -27,6 +29,7 @@ import Distribution.Verbosity
import Distribution.Utils.NubList
import Language.Haskell.Extension

import GHC.Generics (Generic)
import qualified Data.Map as M

-- | A structured set of GHC options/flags
Expand Down Expand Up @@ -211,7 +214,7 @@ data GhcOptions = GhcOptions {
-- Modifies some of the GHC error messages.
ghcOptCabal :: Flag Bool

} deriving Show
} deriving (Show, Generic)


data GhcMode = GhcModeCompile -- ^ @ghc -c@
Expand Down Expand Up @@ -496,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
Loading