Improve error message when './Setup configure' cannot satisfy depende…

…ncies

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.

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

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)