Type families: fixes in the new solver

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

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index 3c7df83..c285c5e 100644 (file)
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -1673,7 +1673,7 @@ data RedEnv
           , red_try_me :: Inst -> WhatToDo
           , red_improve :: Bool                -- True <=> do improvement
           , red_givens :: [Inst]               -- All guaranteed rigid
-                                               -- Always dicts
+                                               -- Always dicts & equalities
                                                -- but see Note [Rigidity]
           , red_stack  :: (Int, [Inst])        -- Recursion stack (for err msg)
                                                -- See Note [RedStack]
@@ -1783,7 +1783,7 @@ reduceContext env wanteds0
            wanteds', 
            normalise_binds,
            eq_improved)     <- tcReduceEqs givens wanteds
-       ; traceTc $ text "reduceContext: tcReduceEqs" <+> vcat
+       ; traceTc $ text "reduceContext: tcReduceEqs result" <+> vcat
                      [ppr givens', ppr wanteds', ppr normalise_binds]
 
           -- Build the Avail mapping from "given_dicts"
@@ -1806,8 +1806,12 @@ reduceContext env wanteds0
          -- as "given"   all the dicts that were originally given, 
          --              *or* for which we now have bindings, 
          --              *or* which are now irreds
-       ; let implic_env = env { red_givens = givens ++ bound_dicts ++
-                                              dict_irreds }
+          -- NB: Equality irreds need to be converted, as the recursive 
+          --     invocation of the solver will still treat them as wanteds
+          --     otherwise.
+       ; let implic_env = env { red_givens 
+                                   = givens ++ bound_dicts ++
+                                     map wantedToLocalEqInst dict_irreds }
        ; (implic_binds_s, implic_irreds_s) 
             <- mapAndUnzipM (reduceImplication implic_env) wanted_implics
        ; let implic_binds  = unionManyBags implic_binds_s
@@ -1928,6 +1932,12 @@ reduceList env@(RedEnv {red_stack = (n,stk)}) wanteds state
     -- Base case: we're done!
 reduce :: RedEnv -> Inst -> Avails -> TcM Avails
 reduce env wanted avails
+
+    -- We don't reduce equalities here (and they must not end up as irreds
+    -- in the Avails!)
+  | isEqInst wanted
+  = return avails
+
     -- It's the same as an existing inst, or a superclass thereof
   | Just _ <- findAvail avails wanted
   = do { traceTc (text "reduce: found " <+> ppr wanted)
@@ -2163,10 +2173,16 @@ reduceImplication env
        -- SLPJ Sept 07: what if improvement happened inside the checkLoop?
        -- Then we must iterate the outer loop too!
 
-       ; traceTc (text "reduceImplication condition" <+> ppr ((isEmptyLHsBinds binds) || (null irreds)))
+        ; let backOff = isEmptyLHsBinds binds &&   -- no new bindings
+                        (not $ null irreds)   &&   -- but still some irreds
+                        all (not . isEqInst) wanteds  
+                          -- we may have instantiated a cotv 
+                          -- => must make a new implication constraint!
 
---     Progress is no longer measered by the number of bindings
-       ; if (isEmptyLHsBinds binds) && (not $ null irreds) then        -- No progress
+       ; traceTc $ text "reduceImplication condition" <+> ppr backOff
+
+          -- Progress is no longer measered by the number of bindings
+       ; if backOff then       -- No progress
                -- If there are any irreds, we back off and do nothing
                return (emptyBag, [orig_implic])
          else do
@@ -2382,6 +2398,9 @@ extractResults (Avails _ avails) wanteds
       = return (binds, bound_dicts, irreds)
 
     go binds bound_dicts irreds done (w:ws)
+      | isEqInst w
+      = go binds bound_dicts (w:irreds) done' ws
+
       | Just done_ids@(done_id : rest_done_ids) <- lookupFM done w
       = if w_id `elem` done_ids then
           go binds bound_dicts irreds done ws