Fix recursive superclasses (again). Fixes Trac #4809.

[ghc-hetmet.git] / compiler / typecheck / TcInteract.lhs

diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index aeb78d8..30b1ae1 100644 (file)
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -402,15 +402,25 @@ React with (F Int ~ b) ==> IR Stop True []    -- after substituting we re-canoni
 solveInteract :: InertSet -> Bag (CtFlavor,EvVar) -> TcS InertSet
 solveInteract inert ws 
   = do { dyn_flags <- getDynFlags
-       ; can_ws    <- foldlBagM (tryPreSolveAndCanon inert) emptyCCan ws
+       ; sctx <- getTcSContext 
+
+       ; traceTcS "solveInteract, before clever canonicalization:" $ 
+         ppr (mapBag (\(ct,ev) -> (ct,evVarPred ev)) ws)
+
+       ; can_ws    <- foldlBagM (tryPreSolveAndCanon sctx inert) emptyCCan ws
+
+       ; traceTcS "solveInteract, after clever canonicalization:" $ 
+         ppr can_ws
+
        ; solveInteractWithDepth (ctxtStkDepth dyn_flags,0,[]) inert can_ws }
 
-tryPreSolveAndCanon :: InertSet -> CanonicalCts -> (CtFlavor, EvVar) -> TcS CanonicalCts
+tryPreSolveAndCanon :: SimplContext -> InertSet -> CanonicalCts -> (CtFlavor, EvVar) -> TcS CanonicalCts
 -- Checks if this constraint can be immediately solved from a constraint in the 
 -- inert set or in the previously encountered CanonicalCts and only then  
 -- canonicalise it. See Note [Avoiding the superclass explosion]
-tryPreSolveAndCanon is cts_acc (fl,ev_var)
+tryPreSolveAndCanon sctx is cts_acc (fl,ev_var)
   | ClassP clas tys <- evVarPred ev_var 
+  , not $ simplEqsOnly sctx -- And we *can* discharge constraints from other constraints
   = do { let (relevant_inert_dicts,_) = getRelevantCts clas (inert_dicts is) 
        ; b <- dischargeFromCans (cts_acc `unionBags` relevant_inert_dicts)
                                 (fl,ev_var,clas,tys)
@@ -1953,12 +1963,11 @@ matchClassInst clas tys loc
                  ; tys <- instDFunTypes mb_inst_tys 
                  ; let (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
                  ; if null theta then
-                       return (GenInst [] (EvDFunApp dfun_id tys [] []))
+                       return (GenInst [] (EvDFunApp dfun_id tys []))
                    else do
                      { ev_vars <- instDFunConstraints theta
                      ; let wevs = [WantedEvVar w loc | w <- ev_vars]
-                     ; return $ GenInst wevs (EvDFunApp dfun_id tys ev_vars ev_vars) }
-                                                           -- NB: All the dependencies are ev_vars
+                     ; return $ GenInst wevs (EvDFunApp dfun_id tys ev_vars) }
                  }
         }
 \end{code}