Skip to content

Commit

Permalink
Rearrange the Monoid instances for Library, Executable, BuildInfo
Browse files Browse the repository at this point in the history 
No functional change, just moving code about.
We now define the Monoid methods directly rather than in
terms of emptyLibrary, unionLibrary etc.
  • Loading branch information
@dcoutts
dcoutts committed Jul 30, 2008
1 parent 3d32210 commit 5a71afd
Showing 1 changed file with 78 additions and 84 deletions.
162 changes: 78 additions & 84 deletions Distribution/PackageDescription.hs
View file
Expand Up @@ -219,11 +219,18 @@ data Library = Library {
deriving (Show, Eq, Read)

instance Monoid Library where
mempty = emptyLibrary
mappend = unionLibrary
mempty = Library {
exposedModules = mempty,
libBuildInfo = mempty
}
mappend a b = Library {
exposedModules = combine exposedModules,
libBuildInfo = combine libBuildInfo
}
where combine field = field a `mappend` field b

emptyLibrary :: Library
emptyLibrary = Library [] emptyBuildInfo
emptyLibrary = mempty

-- |does this package have any libraries?
hasLibs :: PackageDescription -> Bool
Expand All @@ -248,13 +255,6 @@ libModules PackageDescription{library=lib}
= maybe [] exposedModules lib
++ maybe [] (otherModules . libBuildInfo) lib

unionLibrary :: Library -> Library -> Library
unionLibrary l1 l2 =
l1 { exposedModules = combine exposedModules
, libBuildInfo = unionBuildInfo (libBuildInfo l1) (libBuildInfo l2)
}
where combine f = f l1 ++ f l2

-- ---------------------------------------------------------------------------
-- The Executable type

Expand All @@ -266,15 +266,26 @@ data Executable = Executable {
deriving (Show, Read, Eq)

instance Monoid Executable where
mempty = emptyExecutable
mappend = unionExecutable
mempty = Executable {
exeName = mempty,
modulePath = mempty,
buildInfo = mempty
}
mappend a b = Executable{
exeName = combine' exeName,
modulePath = combine modulePath,
buildInfo = combine buildInfo
}
where combine field = field a `mappend` field b
combine' field = case (field a, field b) of
("","") -> ""
("", x) -> x
(x, "") -> x
(x, y) -> error $ "Ambiguous values for executable field: '"
++ x ++ "' and '" ++ y ++ "'"

emptyExecutable :: Executable
emptyExecutable = Executable {
exeName = "",
modulePath = "",
buildInfo = emptyBuildInfo
}
emptyExecutable = mempty

-- |does this package have any executables?
hasExes :: PackageDescription -> Bool
Expand All @@ -291,19 +302,6 @@ exeModules :: PackageDescription -> [ModuleName]
exeModules PackageDescription{executables=execs}
= concatMap (otherModules . buildInfo) execs

unionExecutable :: Executable -> Executable -> Executable
unionExecutable e1 e2 =
e1 { exeName = combine exeName
, modulePath = combine modulePath
, buildInfo = unionBuildInfo (buildInfo e1) (buildInfo e2)
}
where combine f = case (f e1, f e2) of
("","") -> ""
("", x) -> x
(x, "") -> x
(x, y) -> error $ "Ambiguous values for executable field: '"
++ x ++ "' and '" ++ y ++ "'"

-- ---------------------------------------------------------------------------
-- The BuildInfo type

Expand Down Expand Up @@ -335,32 +333,56 @@ data BuildInfo = BuildInfo {
deriving (Show,Read,Eq)

instance Monoid BuildInfo where
mempty = emptyBuildInfo
mappend = unionBuildInfo
mempty = BuildInfo {
buildable = True,
buildTools = [],
cppOptions = [],
ccOptions = [],
ldOptions = [],
pkgconfigDepends = [],
frameworks = [],
cSources = [],
hsSourceDirs = [],
otherModules = [],
extensions = [],
extraLibs = [],
extraLibDirs = [],
includeDirs = [],
includes = [],
installIncludes = [],
options = [],
ghcProfOptions = [],
ghcSharedOptions = [],
customFieldsBI = []
}
mappend a b = BuildInfo {
buildable = buildable a && buildable b,
buildTools = combineNub buildTools,
cppOptions = combine cppOptions,
ccOptions = combine ccOptions,
ldOptions = combine ldOptions,
pkgconfigDepends = combineNub pkgconfigDepends,
frameworks = combineNub frameworks,
cSources = combineNub cSources,
hsSourceDirs = combineNub hsSourceDirs,
otherModules = combineNub otherModules,
extensions = combineNub extensions,
extraLibs = combine extraLibs,
extraLibDirs = combineNub extraLibDirs,
includeDirs = combineNub includeDirs,
includes = combineNub includes,
installIncludes = combineNub installIncludes,
options = combine options,
ghcProfOptions = combine ghcProfOptions,
ghcSharedOptions = combine ghcSharedOptions,
customFieldsBI = combine customFieldsBI
}
where
combine field = field a `mappend` field b
combineNub field = nub (combine field)

emptyBuildInfo :: BuildInfo
emptyBuildInfo = BuildInfo {
buildable = True,
buildTools = [],
cppOptions = [],
ccOptions = [],
ldOptions = [],
pkgconfigDepends = [],
frameworks = [],
cSources = [],
hsSourceDirs = [],
otherModules = [],
extensions = [],
extraLibs = [],
extraLibDirs = [],
includeDirs = [],
includes = [],
installIncludes = [],
options = [],
ghcProfOptions = [],
ghcSharedOptions = [],
customFieldsBI = []
}
emptyBuildInfo = mempty

-- | The 'BuildInfo' for the library (if there is one and it's buildable) and
-- all the buildable executables. Useful for gathering dependencies.
Expand Down Expand Up @@ -394,7 +416,7 @@ updatePackageDescription (mb_lib_bi, exe_bi) p
}
where
updateLibrary :: Maybe BuildInfo -> Maybe Library -> Maybe Library
updateLibrary (Just bi) (Just lib) = Just (lib{libBuildInfo = unionBuildInfo bi (libBuildInfo lib)})
updateLibrary (Just bi) (Just lib) = Just (lib{libBuildInfo = bi `mappend` libBuildInfo lib})
updateLibrary Nothing mb_lib = mb_lib

--the lib only exists in the buildinfo file. FIX: Is this
Expand All @@ -412,37 +434,9 @@ updatePackageDescription (mb_lib_bi, exe_bi) p
-> [Executable] -- ^libst with exeName updated
updateExecutable _ [] = []
updateExecutable exe_bi'@(name,bi) (exe:exes)
| exeName exe == name = exe{buildInfo = unionBuildInfo bi (buildInfo exe)} : exes
| exeName exe == name = exe{buildInfo = bi `mappend` buildInfo exe} : exes
| otherwise = exe : updateExecutable exe_bi' exes

unionBuildInfo :: BuildInfo -> BuildInfo -> BuildInfo
unionBuildInfo b1 b2
= BuildInfo {
buildable = buildable b1 && buildable b2,
buildTools = combineNub buildTools,
cppOptions = combine cppOptions,
ccOptions = combine ccOptions,
ldOptions = combine ldOptions,
pkgconfigDepends = combineNub pkgconfigDepends,
frameworks = combineNub frameworks,
cSources = combineNub cSources,
hsSourceDirs = combineNub hsSourceDirs,
otherModules = combineNub otherModules,
extensions = combineNub extensions,
extraLibs = combine extraLibs,
extraLibDirs = combineNub extraLibDirs,
includeDirs = combineNub includeDirs,
includes = combineNub includes,
installIncludes = combineNub installIncludes,
options = combine options,
ghcProfOptions = combine ghcProfOptions,
ghcSharedOptions = combine ghcSharedOptions,
customFieldsBI = combine customFieldsBI
}
where
combine f = f b1 ++ f b2
combineNub f = nub (combine f)

-- ---------------------------------------------------------------------------
-- The GenericPackageDescription type

Expand Down

0 comments on commit 5a71afd

Please sign in to comment.