DependencyMap rework

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

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