From 4f6d9fe367f3b1f36a07849b8a0c5a52dd65c321 Mon Sep 17 00:00:00 2001 From: Kristen Kozak Date: Sat, 14 Nov 2015 14:09:39 -0800 Subject: [PATCH] Improve error message when './Setup configure' cannot satisfy dependencies This commit takes the union of all dependencies that caused Cabal to backtrack when trying different combinations of flags. Previously, Cabal printed the shortest list of missing dependencies from a single flag assignment. The new error message requires less searching. --- .../PackageDescription/Configuration.hs | 77 ++++++++++--------- Cabal/Distribution/Simple/Configure.hs | 2 +- 2 files changed, 41 insertions(+), 38 deletions(-) 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)