[commit: Cabal] master: collapse repeated flag choices (755f328)

[Ian Lynagh]

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 <andres at well-typed.com>
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