diff --git a/Cabal/Distribution/PackageDescription/Configuration.hs b/Cabal/Distribution/PackageDescription/Configuration.hs index bf96132cc7f..daedefafef1 100644 --- a/Cabal/Distribution/PackageDescription/Configuration.hs +++ b/Cabal/Distribution/PackageDescription/Configuration.hs @@ -39,7 +39,8 @@ import Distribution.PackageDescription import Distribution.PackageDescription.Utils ( cabalBug, userBug ) import Distribution.Version - ( VersionRange, anyVersion, intersectVersionRanges, withinRange ) + ( VersionRange, anyVersion, intersectVersionRanges + , simplifyVersionRange, unionVersionRanges, withinRange ) import Distribution.Compiler ( CompilerId(CompilerId) ) import Distribution.System @@ -189,7 +190,7 @@ instance Monoid d => Mon.Monoid (DepTestRslt d) where mappend (MissingDeps d) (MissingDeps d') = MissingDeps (d `mappend` d') -data Tree a = Tree a [Tree a] +data Tree a = Tree a [Tree a] -- very simple tree -- | Try to find a flag assignment that satisfies the constraints of all trees. @@ -198,8 +199,9 @@ data Tree a = Tree a [Tree a] -- resulting data, the associated dependencies, and the chosen flag -- assignments. -- --- In case of failure, the _smallest_ number of of missing dependencies is --- returned. [TODO: Could also be specified with a function argument.] +-- In case of failure, the union of the dependencies that led to backtracking +-- on all branches is returned. +-- [TODO: Could also be specified with a function argument.] -- -- TODO: The current algorithm is rather naive. A better approach would be to: -- @@ -224,7 +226,8 @@ resolveWithFlags :: -> Either [Dependency] (TargetSet PDTagged, FlagAssignment) -- ^ Either the missing dependencies (error case), or a pair of -- (set of build targets with dependencies, chosen flag assignments) -resolveWithFlags dom os arch impl constrs trees checkDeps = explore $ build dom [] +resolveWithFlags dom os arch impl constrs trees checkDeps = + either (Left . fromDepMapUnion) Right $ explore (build dom []) where extraConstrs = toDepMap constrs @@ -234,12 +237,13 @@ resolveWithFlags dom os arch impl constrs trees checkDeps = explore $ build dom . mapTreeConds (fst . simplifyWithSysParams os arch impl)) trees - -- @try@ recursively tries all possible flag assignments in the domain and - -- either succeeds or returns a binary tree with the missing dependencies - -- encountered in each run. Since the tree is constructed lazily, we - -- avoid some computation overhead in the successful case. + -- @explore@ searches a tree of assignments, backtracking whenever a flag + -- introduces a dependency that cannot be satisfied. If there is no + -- solution, @explore@ returns the union of all dependencies that caused + -- it to backtrack. Since the tree is constructed lazily, we avoid some + -- computation overhead in the successful case. explore :: Tree FlagAssignment - -> Either [Dependency] (TargetSet PDTagged, FlagAssignment) + -> Either DepMapUnion (TargetSet PDTagged, FlagAssignment) explore (Tree flags ts) = let targetSet = TargetSet $ flip map simplifiedTrees $ -- apply additional constraints to all dependencies @@ -249,46 +253,44 @@ resolveWithFlags dom os arch impl constrs trees checkDeps = explore $ build dom in case checkDeps (fromDepMap deps) of DepOk | null ts -> Right (targetSet, flags) | otherwise -> tryAll $ map explore ts - MissingDeps mds -> Left mds + MissingDeps mds -> Left (toDepMapUnion mds) - build :: [(FlagName, [Bool])] - -> FlagAssignment - -> Tree FlagAssignment + -- Builds a tree of all possible flag assignments. Internal nodes + -- have only partial assignments. + build :: [(FlagName, [Bool])] -> FlagAssignment -> Tree FlagAssignment build [] flags = Tree flags [] build ((n, vals):rest) flags = Tree flags $ map (\v -> build rest ((n, v):flags)) vals - tryAll :: [Either [a] b] -> Either [a] b + tryAll :: [Either DepMapUnion a] -> Either DepMapUnion a tryAll = foldr mp mz -- special version of `mplus' for our local purposes - mp :: Either [a] b -> Either [a] b -> Either [a] b + mp :: Either DepMapUnion a -> Either DepMapUnion a -> Either DepMapUnion a mp m@(Right _) _ = m mp _ m@(Right _) = m - mp (Left xs) (Left ys) = let shortest = findShortest xs ys - in shortest `seq` Left shortest + mp (Left xs) (Left ys) = + let union = Map.foldrWithKey (Map.insertWith' combine) + (unDepMapUnion xs) (unDepMapUnion ys) + combine x y = simplifyVersionRange $ unionVersionRanges x y + in union `seq` Left (DepMapUnion union) -- `mzero' - mz :: Either [a] b - mz = Left [] + mz :: Either DepMapUnion a + mz = Left (DepMapUnion Map.empty) env :: FlagAssignment -> FlagName -> Either FlagName Bool env flags flag = (maybe (Left flag) Right . lookup flag) flags - -- for the error case we inspect our lazy tree of missing dependencies and - -- pick the shortest list of missing dependencies - findShortest l r = - case (l,r) of - ([], xs) -> xs -- [] is too short - (xs, []) -> xs - ([x], _) -> [x] -- single elem is optimum - (_, [x]) -> [x] - (xs, ys) -> if lazyLengthCmp xs ys - then xs else ys - -- lazy variant of @\xs ys -> length xs <= length ys@ - lazyLengthCmp [] _ = True - lazyLengthCmp _ [] = False - lazyLengthCmp (_:xs) (_:ys) = lazyLengthCmp xs ys +-- | A map of dependencies that combines version ranges using 'unionVersionRanges'. +newtype DepMapUnion = DepMapUnion { unDepMapUnion :: Map PackageName VersionRange } + +toDepMapUnion :: [Dependency] -> DepMapUnion +toDepMapUnion ds = + DepMapUnion $ fromListWith unionVersionRanges [ (p,vr) | Dependency p vr <- ds ] + +fromDepMapUnion :: DepMapUnion -> [Dependency] +fromDepMapUnion m = [ Dependency p vr | (p,vr) <- toList (unDepMapUnion m) ] -- | A map of dependencies. Newtyped since the default monoid instance is not -- appropriate. The monoid instance uses 'intersectVersionRanges'. @@ -470,9 +472,10 @@ instance Monoid PDTagged where -- -- This function will fail if it cannot find a flag assignment that leads to -- satisfiable dependencies. (It will not try alternative assignments for --- explicitly specified flags.) In case of failure it will return a /minimum/ --- number of dependencies that could not be satisfied. On success, it will --- return the package description and the full flag assignment chosen. +-- explicitly specified flags.) In case of failure it will return the missing +-- dependencies that it encountered when trying different flag assignments. +-- On success, it will return the package description and the full flag +-- assignment chosen. -- finalizePackageDescription :: FlagAssignment -- ^ Explicitly specified flag assignments diff --git a/Cabal/Distribution/Simple/Configure.hs b/Cabal/Distribution/Simple/Configure.hs index 5e216d51296..962d238e0eb 100644 --- a/Cabal/Distribution/Simple/Configure.hs +++ b/Cabal/Distribution/Simple/Configure.hs @@ -470,7 +470,7 @@ configure (pkg_descr0, pbi) cfg pkg_descr0'' of Right r -> return r Left missing -> - die $ "At least the following dependencies are missing:\n" + die $ "Encountered missing dependencies:\n" ++ (render . nest 4 . sep . punctuate comma . map (disp . simplifyDependency) $ missing)