Repository : ssh://darcs.haskell.org//srv/darcs/packages/Cabal On branch : master
http://hackage.haskell.org/trac/ghc/changeset/755f3289b2d3a16e1f302c41c45741c16f2b2543 >--------------------------------------------------------------- commit 755f3289b2d3a16e1f302c41c45741c16f2b2543 Author: Andres Loeh <[email protected]> Date: Thu Oct 27 16:11:20 2011 +0000 collapse repeated flag choices In the build phase, we allow the same flag choice to occur multiple times. This makes it easy to handle the situation where the same flag occurs several times in the condition tree, and hence new goals and dependencies might be introduced depending on the choice. Previously, we have ensured during validation that repeated flag choices are consistent. This behaviour has now been replaced by the new approach to collapse repeated flag choice nodes completely during validation. The advantage is that the tree is less deep, and that the trace output looks less strange. Repeated flag choices are no longer seen, which I think avoids confusion. >--------------------------------------------------------------- .../Client/Dependency/Modular/Message.hs | 2 +- .../Distribution/Client/Dependency/Modular/Tree.hs | 2 +- .../Client/Dependency/Modular/Validate.hs | 41 +++++++++++-------- 3 files changed, 26 insertions(+), 19 deletions(-) diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Message.hs b/cabal-install/Distribution/Client/Dependency/Modular/Message.hs index 5f543a1..813c22e 100644 --- a/cabal-install/Distribution/Client/Dependency/Modular/Message.hs +++ b/cabal-install/Distribution/Client/Dependency/Modular/Message.hs @@ -75,7 +75,6 @@ showGR (FDependency qfn b) = " (dependency of " ++ showQFNBool qfn b ++ ")" showFR :: ConflictSet QPN -> FailReason -> String showFR _ InconsistentInitialConstraints = " (inconsistent initial constraints)" showFR _ (Conflicting ds) = " (conflict: " ++ L.intercalate ", " (map showDep ds) ++ ")" -showFR _ ConflictingFlag = " (conflicts with previous choice of same flag)" showFR _ CannotInstall = " (only already installed versions can be used)" showFR _ CannotReinstall = " (avoiding to reinstall a package with same version but new dependencies)" showFR _ (GlobalConstraintVersion vr) = " (global constraint requires " ++ display vr ++ ")" @@ -87,4 +86,5 @@ showFR c Backjump = " (backjumping, conflict set: " ++ sho -- interest of not crashing unnecessarily, we still just print an error -- message though. showFR _ (BuildFailureNotInIndex pn) = " (BUILD FAILURE: NOT IN INDEX: " ++ display pn ++ ")" +showFR _ (MalformedFlagChoice qfn) = " (INTERNAL ERROR: MALFORMED FLAG CHOICE: " ++ showQFN qfn ++ ")" showFR _ EmptyGoalChoice = " (INTERNAL ERROR: EMPTY GOAL CHOICE)" diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs b/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs index c0458f9..ba9981f 100644 --- a/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs +++ b/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs @@ -30,7 +30,6 @@ instance Functor Tree where data FailReason = InconsistentInitialConstraints | Conflicting [Dep QPN] - | ConflictingFlag | CannotInstall | CannotReinstall | GlobalConstraintVersion VR @@ -38,6 +37,7 @@ data FailReason = InconsistentInitialConstraints | GlobalConstraintSource | GlobalConstraintFlag | BuildFailureNotInIndex PN + | MalformedFlagChoice QFN | EmptyGoalChoice | Backjump deriving (Eq, Show) diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs b/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs index bf6141b..ae5e335 100644 --- a/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs +++ b/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs @@ -85,11 +85,23 @@ validate = cata go where go :: TreeF (QGoalReasons, Scope) (Validate (Tree QGoalReasons)) -> Validate (Tree QGoalReasons) - go (PChoiceF qpn (gr, sc) ts) = PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn gr sc) ts) - go (FChoiceF qfn (gr, _sc) b ts) = FChoice qfn gr b <$> sequence (P.mapWithKey (goF qfn gr ) ts) + go (PChoiceF qpn (gr, sc) ts) = PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn gr sc) ts) + go (FChoiceF qfn (gr, _sc) b ts) = + do + -- Flag choices may occur repeatedly (because they can introduce new constraints + -- in various places). However, subsequent choices must be consistent. We thereby + -- collapse repeated flag choice nodes. + PA _ pfa <- asks pa -- obtain current flag-preassignment + case M.lookup qfn pfa of + Just rb -> -- flag has already been assigned; collapse choice to the correct branch + case P.lookup rb ts of + Just t -> goF qfn gr rb t + Nothing -> return $ Fail (toConflictSet (Goal (F qfn) gr)) (MalformedFlagChoice qfn) + Nothing -> -- flag choice is new, follow both branches + FChoice qfn gr b <$> sequence (P.mapWithKey (goF qfn gr) ts) -- We don't need to do anything for goal choices or failure nodes. - go (GoalChoiceF ts) = GoalChoice <$> sequence ts + go (GoalChoiceF ts) = GoalChoice <$> sequence ts go (DoneF rdm ) = pure (Done rdm) go (FailF c fr ) = pure (Fail c fr) @@ -127,20 +139,15 @@ validate = cata go -- We take the *saved* dependencies, because these have been qualified in the -- correct scope. -- - -- First, we should check if our flag choice itself is consistent. Unlike for - -- package nodes, we do not guarantee that a flag choice occurs exactly once. - case M.lookup qfn pfa of - Just rb | rb /= b -> return (Fail (toConflictSet (Goal (F qfn) gr)) ConflictingFlag) - _ -> do - -- Extend the flag assignment - let npfa = M.insert qfn b pfa - -- We now try to get the new active dependencies we might learn about because - -- we have chosen a new flag. - let newactives = extractNewFlagDeps qfn gr b npfa qdeps - -- As in the package case, we try to extend the partial assignment. - case extend (F qfn) ppa newactives of - Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found - Right nppa -> local (\ s -> s { pa = PA nppa npfa }) r + -- Extend the flag assignment + let npfa = M.insert qfn b pfa + -- We now try to get the new active dependencies we might learn about because + -- we have chosen a new flag. + let newactives = extractNewFlagDeps qfn gr b npfa qdeps + -- As in the package case, we try to extend the partial assignment. + case extend (F qfn) ppa newactives of + Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found + Right nppa -> local (\ s -> s { pa = PA nppa npfa }) r -- | We try to extract as many concrete dependencies from the given flagged -- dependencies as possible. We make use of all the flag knowledge we have _______________________________________________ Cvs-libraries mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-libraries
