Commit 978aea20 authored by Duncan Coutts's avatar Duncan Coutts Committed by Edward Z. Yang
Browse files

Use MapMappend monoid for the package-specific config

It's a Map PackageName PackageConfig (or LegacyPackageConfig) so the
correct monoid instance is to merge the PackageConfig values.
parent 916a502a
......@@ -9,6 +9,8 @@ module Distribution.Client.ProjectConfig (
ProjectConfigBuildOnly(..),
ProjectConfigShared(..),
PackageConfig(..),
MapLast(..),
MapMappend(..),
-- * Project config files
findProjectRoot,
......@@ -113,7 +115,8 @@ lookupLocalPackageConfig field ProjectConfig {
projectConfigSpecificPackage
} pkgname =
field projectConfigLocalPackages
<> maybe mempty field (Map.lookup pkgname projectConfigSpecificPackage)
<> maybe mempty field
(Map.lookup pkgname (getMapMappend projectConfigSpecificPackage))
-- | Use a 'RepoContext' based on the 'BuildTimeSettings'.
......
......@@ -80,7 +80,6 @@ import Distribution.Simple.Command
import Control.Applicative
#endif
import Control.Monad
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Char (isSpace)
import Distribution.Compat.Semigroup
......@@ -107,7 +106,7 @@ data LegacyProjectConfig = LegacyProjectConfig {
legacySharedConfig :: LegacySharedConfig,
legacyLocalConfig :: LegacyPackageConfig,
legacySpecificConfig :: Map PackageName LegacyPackageConfig
legacySpecificConfig :: MapMappend PackageName LegacyPackageConfig
} deriving Generic
instance Monoid LegacyProjectConfig where
......@@ -1054,7 +1053,9 @@ packageSpecificOptionsSectionDescr =
sectionSubsections = [],
sectionGet = \projconf ->
[ (display pkgname, pkgconf)
| (pkgname, pkgconf) <- Map.toList (legacySpecificConfig projconf) ],
| (pkgname, pkgconf) <-
Map.toList . getMapMappend
. legacySpecificConfig $ projconf ],
sectionSet =
\lineno pkgnamestr pkgconf projconf -> do
pkgname <- case simpleParse pkgnamestr of
......@@ -1064,8 +1065,9 @@ packageSpecificOptionsSectionDescr =
++ "as an argument"
return projconf {
legacySpecificConfig =
MapMappend $
Map.insertWith mappend pkgname pkgconf
(legacySpecificConfig projconf)
(getMapMappend $ legacySpecificConfig projconf)
},
sectionEmpty = mempty
}
......
......@@ -99,7 +99,7 @@ data ProjectConfig
projectConfigBuildOnly :: ProjectConfigBuildOnly,
projectConfigShared :: ProjectConfigShared,
projectConfigLocalPackages :: PackageConfig,
projectConfigSpecificPackage :: Map PackageName PackageConfig
projectConfigSpecificPackage :: MapMappend PackageName PackageConfig
}
deriving (Eq, Show, Generic)
......
......@@ -667,7 +667,7 @@ rebuildInstallPlan verbosity
defaultInstallDirs
projectConfigShared
projectConfigLocalPackages
projectConfigSpecificPackage
(getMapMappend projectConfigSpecificPackage)
where
withRepoCtx = projectConfigWithSolverRepoContext verbosity
cabalPackageCacheDirectory
......
......@@ -122,7 +122,7 @@ prop_roundtrip_legacytypes_local config =
prop_roundtrip_legacytypes_specific :: Map PackageName PackageConfig -> Bool
prop_roundtrip_legacytypes_specific config =
roundtrip_legacytypes
mempty { projectConfigSpecificPackage = config }
mempty { projectConfigSpecificPackage = MapMappend config }
--------------------------------------------
......@@ -213,7 +213,7 @@ prop_roundtrip_printparse_specific :: Map PackageName (NonMEmpty PackageConfig)
prop_roundtrip_printparse_specific config =
roundtrip_printparse
mempty {
projectConfigSpecificPackage = fmap getNonMEmpty config
projectConfigSpecificPackage = MapMappend (fmap getNonMEmpty config)
}
......@@ -242,14 +242,17 @@ instance Arbitrary ProjectConfig where
<*> arbitrary
<*> arbitrary <*> arbitrary
<*> arbitrary
<*> (fmap getNonMEmpty . Map.fromList <$> shortListOf 3 arbitrary)
<*> (MapMappend . fmap getNonMEmpty . Map.fromList
<$> shortListOf 3 arbitrary)
-- package entries with no content are equivalent to
-- the entry not existing at all, so exclude empty
shrink (ProjectConfig x0 x1 x2 x3 x4 x5 x6 x7) =
[ ProjectConfig x0' x1' x2' x3' x4' x5' x6' (fmap getNonMEmpty x7')
[ ProjectConfig x0' x1' x2' x3'
x4' x5' x6' (MapMappend (fmap getNonMEmpty x7'))
| ((x0', x1', x2', x3'), (x4', x5', x6', x7'))
<- shrink ((x0, x1, x2, x3), (x4, x5, x6, fmap NonMEmpty x7))
<- shrink ((x0, x1, x2, x3),
(x4, x5, x6, fmap NonMEmpty (getMapMappend x7)))
]
newtype PackageLocationString
......
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