diff --git a/Cabal-syntax/src/Distribution/PackageDescription/Configuration.hs b/Cabal-syntax/src/Distribution/PackageDescription/Configuration.hs index e811c361221..85574793254 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/Configuration.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/Configuration.hs @@ -61,7 +61,6 @@ import Distribution.Utils.Generic import Distribution.Utils.Path (sameDirectory) import Distribution.Version -import qualified Data.Map.Lazy as Map import Data.Tree (Tree (Node)) ------------------------------------------------------------------------------ @@ -196,14 +195,14 @@ resolveWithFlags -- ^ Either the missing dependencies (error case), or a pair of -- (set of build targets with dependencies, chosen flag assignments) resolveWithFlags dom enabled os arch impl constrs trees checkDeps = - either (Left . fromDepMapUnion) Right $ explore (build mempty dom) + either (Left . fromDepMapJoin) Right $ explore (build mempty dom) where -- simplify trees by (partially) evaluating all conditions and converting -- dependencies to dependency maps. - simplifiedTrees :: [CondTree FlagName DependencyMap PDTagged] + simplifiedTrees :: [CondTree FlagName DependencyMapMeet PDTagged] simplifiedTrees = map - ( mapTreeConstrs toDepMap -- convert to maps + ( mapTreeConstrs toDepMapMeet -- convert to maps . addBuildableConditionPDTagged . mapTreeConds (fst . simplifyWithSysParams os arch impl) ) @@ -216,20 +215,19 @@ resolveWithFlags dom enabled os arch impl constrs trees checkDeps = -- computation overhead in the successful case. explore :: Tree FlagAssignment - -> Either DepMapUnion (TargetSet PDTagged, FlagAssignment) + -> Either DependencyMapJoin (TargetSet PDTagged, FlagAssignment) explore (Node flags ts) = let targetSet = TargetSet $ - flip map simplifiedTrees $ - -- apply additional constraints to all dependencies - first (`constrainBy` constrs) - . simplifyCondTree (env flags) + -- apply additional constraints to all dependencies + map (first (`constrainBy` constrs) . simplifyCondTree (env flags)) + simplifiedTrees deps = overallDependencies enabled targetSet - in case checkDeps (fromDepMap deps) of + in case checkDeps (fromDepMapMeet deps) of DepOk | null ts -> Right (targetSet, flags) | otherwise -> tryAll $ map explore ts - MissingDeps mds -> Left (toDepMapUnion mds) + MissingDeps mds -> Left (toDepMapJoin mds) -- Builds a tree of all possible flag assignments. Internal nodes -- have only partial assignments. @@ -238,18 +236,18 @@ resolveWithFlags dom enabled os arch impl constrs trees checkDeps = build assigned ((fn, vals) : unassigned) = Node assigned $ map (\v -> build (insertFlagAssignment fn v assigned) unassigned) vals - tryAll :: [Either DepMapUnion a] -> Either DepMapUnion a + tryAll :: [Either DependencyMapJoin a] -> Either DependencyMapJoin a tryAll = foldr mp mz -- special version of `mplus' for our local purposes - mp :: Either DepMapUnion a -> Either DepMapUnion a -> Either DepMapUnion a + mp :: Either DependencyMapJoin a -> Either DependencyMapJoin a -> Either DependencyMapJoin a mp m@(Right _) _ = m mp _ m@(Right _) = m mp (Left xs) (Left ys) = Left (xs <> ys) -- `mzero' - mz :: Either DepMapUnion a - mz = Left (DepMapUnion Map.empty) + mz :: Either DependencyMapJoin a + mz = Left mempty env :: FlagAssignment -> FlagName -> Either FlagName Bool env flags flag = (maybe (Left flag) Right . lookupFlagAssignment flag) flags @@ -323,27 +321,6 @@ extractConditions f gpkg = , extractCondition (f . benchmarkBuildInfo) . snd <$> condBenchmarks gpkg ] --- | A map of package constraints that combines version ranges using 'unionVersionRanges'. -newtype DepMapUnion = DepMapUnion {unDepMapUnion :: Map PackageName (VersionRange, NonEmptySet LibraryName)} - -instance Semigroup DepMapUnion where - DepMapUnion x <> DepMapUnion y = - DepMapUnion $ - Map.unionWith unionVersionRanges' x y - -unionVersionRanges' - :: (VersionRange, NonEmptySet LibraryName) - -> (VersionRange, NonEmptySet LibraryName) - -> (VersionRange, NonEmptySet LibraryName) -unionVersionRanges' (vr, cs) (vr', cs') = (unionVersionRanges vr vr', cs <> cs') - -toDepMapUnion :: [Dependency] -> DepMapUnion -toDepMapUnion ds = - DepMapUnion $ Map.fromListWith unionVersionRanges' [(p, (vr, cs)) | Dependency p vr cs <- ds] - -fromDepMapUnion :: DepMapUnion -> [Dependency] -fromDepMapUnion m = [Dependency p vr cs | (p, (vr, cs)) <- Map.toList (unDepMapUnion m)] - freeVars :: CondTree ConfVar c a -> [FlagName] freeVars t = [f | PackageFlag f <- freeVars' t] where @@ -359,11 +336,11 @@ freeVars t = [f | PackageFlag f <- freeVars' t] ------------------------------------------------------------------------------ -- | A set of targets with their package dependencies -newtype TargetSet a = TargetSet [(DependencyMap, a)] +newtype TargetSet a = TargetSet [(DependencyMapMeet, a)] -- | Combine the target-specific dependencies in a TargetSet to give the -- dependencies for the package as a whole. -overallDependencies :: ComponentRequestedSpec -> TargetSet PDTagged -> DependencyMap +overallDependencies :: ComponentRequestedSpec -> TargetSet PDTagged -> DependencyMapMeet overallDependencies enabled (TargetSet targets) = mconcat depss where (depss, _) = unzip $ filter (removeDisabledSections . snd) targets @@ -401,7 +378,7 @@ flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, []) targets (PDNull, x) -> x -- actually this should not happen, but let's be liberal where redoBD :: L.HasBuildInfo a => a -> a - redoBD = set L.targetBuildDepends $ fromDepMap depMap + redoBD = set L.targetBuildDepends $ fromDepMapMeet depMap ------------------------------------------------------------------------------ -- Convert GenericPackageDescription to PackageDescription diff --git a/Cabal-syntax/src/Distribution/Types/DependencyMap.hs b/Cabal-syntax/src/Distribution/Types/DependencyMap.hs index aebca2c4cbf..5aab6584f4f 100644 --- a/Cabal-syntax/src/Distribution/Types/DependencyMap.hs +++ b/Cabal-syntax/src/Distribution/Types/DependencyMap.hs @@ -3,6 +3,12 @@ module Distribution.Types.DependencyMap , toDepMap , fromDepMap , constrainBy + , DependencyMapMeet + , toDepMapMeet + , fromDepMapMeet + , DependencyMapJoin + , fromDepMapJoin + , toDepMapJoin ) where import Distribution.Compat.Prelude @@ -16,44 +22,75 @@ import Distribution.Version import qualified Data.Map.Lazy as Map --- | A map of dependencies. Newtyped since the default monoid instance is not --- appropriate. The monoid instance uses 'intersectVersionRanges'. -newtype DependencyMap = DependencyMap {unDependencyMap :: Map PackageName (VersionRange, NonEmptySet LibraryName)} +class Lattice a where + -- | join + (\/) :: a -> a -> a + + infixr 5 \/ + + -- | meet + (/\) :: a -> a -> a + + infixr 6 /\ + +newtype Meet a = Meet {getMeet :: a} deriving (Show, Read, Eq) -instance Monoid DependencyMap where - mempty = DependencyMap Map.empty - mappend = (<>) +instance Lattice a => Semigroup (Meet a) where + Meet lhs <> Meet rhs = Meet (lhs /\ rhs) -instance Semigroup DependencyMap where - (DependencyMap a) <> (DependencyMap b) = - DependencyMap (Map.unionWith intersectVersionRangesAndJoinComponents a b) +newtype Join a = Join {getJoin :: a} + deriving (Show, Read, Eq) + +instance Lattice a => Semigroup (Join a) where + Join lhs <> Join rhs = Join (lhs \/ rhs) + +instance Lattice VersionRange where + (\/) = unionVersionRanges + (/\) = intersectVersionRanges + +newtype MonoidalMap k v = MonoidalMap {getMonoidalMap :: Map k v} + deriving (Show, Read, Eq) -intersectVersionRangesAndJoinComponents - :: (VersionRange, NonEmptySet LibraryName) - -> (VersionRange, NonEmptySet LibraryName) - -> (VersionRange, NonEmptySet LibraryName) -intersectVersionRangesAndJoinComponents (va, ca) (vb, cb) = - (intersectVersionRanges va vb, ca <> cb) +instance (Semigroup v, Ord k) => Monoid (MonoidalMap k v) where + mempty = MonoidalMap mempty -toDepMap :: [Dependency] -> DependencyMap -toDepMap ds = - DependencyMap $ Map.fromListWith intersectVersionRangesAndJoinComponents [(p, (vr, cs)) | Dependency p vr cs <- ds] +instance (Semigroup v, Ord k) => Semigroup (MonoidalMap k v) where + MonoidalMap m1 <> MonoidalMap m2 = MonoidalMap (Map.unionWith (<>) m1 m2) -fromDepMap :: DependencyMap -> [Dependency] -fromDepMap m = [Dependency p vr cs | (p, (vr, cs)) <- Map.toList (unDependencyMap m)] +type DependencyMap l = MonoidalMap PackageName (l, NonEmptySet LibraryName) + +toDepMap :: Semigroup a => (VersionRange -> a) -> [Dependency] -> DependencyMap a +toDepMap meetOrJoin ds = mconcat [MonoidalMap (Map.singleton p (meetOrJoin vr, cs)) | Dependency p vr cs <- ds] + +fromDepMap :: (l -> VersionRange) -> MonoidalMap PackageName (l, NonEmptySet LibraryName) -> [Dependency] +fromDepMap unMeetOrJoin m = [Dependency p (unMeetOrJoin vr) cs | (p, (vr, cs)) <- Map.toList (getMonoidalMap m)] + +type DependencyMapMeet = DependencyMap (Meet VersionRange) + +toDepMapMeet :: [Dependency] -> DependencyMapMeet +toDepMapMeet = toDepMap Meet + +fromDepMapMeet :: DependencyMapMeet -> [Dependency] +fromDepMapMeet = fromDepMap getMeet -- Apply extra constraints to a dependency map. -- Combines dependencies where the result will only contain keys from the left -- (first) map. If a key also exists in the right map, both constraints will -- be intersected. constrainBy - :: DependencyMap + :: DependencyMapMeet -> [PackageVersionConstraint] - -> DependencyMap + -> DependencyMapMeet constrainBy = foldl' tightenConstraint where - tightenConstraint (DependencyMap l) (PackageVersionConstraint pn vr) = DependencyMap $ - case Map.lookup pn l of - Nothing -> l - Just (vr', cs) -> Map.insert pn (intersectVersionRanges vr' vr, cs) l + tightenConstraint (MonoidalMap m) (PackageVersionConstraint pn vr) = + MonoidalMap $ Map.adjust (\(vr', cs) -> (vr' <> Meet vr, cs)) pn m + +type DependencyMapJoin = MonoidalMap PackageName (Join VersionRange, NonEmptySet LibraryName) + +toDepMapJoin :: [Dependency] -> DependencyMapJoin +toDepMapJoin = toDepMap Join + +fromDepMapJoin :: DependencyMapJoin -> [Dependency] +fromDepMapJoin = fromDepMap getJoin