[commit: ghc] ghc-new-flavor: Small bugfix (for indexed_types/should_compile/T2291.hs). Because our (4e0f1a0)

[dimitris at microsoft.com]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : ghc-new-flavor

http://hackage.haskell.org/trac/ghc/changeset/4e0f1a02944c6df6df3dad55494384a7f411c984

>---------------------------------------------------------------

commit 4e0f1a02944c6df6df3dad55494384a7f411c984
Author: Dimitrios Vytiniotis <dimitris at microsoft.com>
Date:   Thu Mar 29 10:18:45 2012 +0200

    Small bugfix (for indexed_types/should_compile/T2291.hs). Because our
    inert sets do not tolerate more than a single constraint per family head
    we have to allow family interactions /with the inerts/ (not with top-level)
    when the context says simplEqsOnly.

>---------------------------------------------------------------

 compiler/typecheck/TcInteract.lhs |   30 +++++++++++++++++-------------
 1 files changed, 17 insertions(+), 13 deletions(-)

diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index 9116bb5..db61542 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -403,7 +403,7 @@ rewriteInertEqsFromInertEq (subst_tv, subst_co, subst_fl) ieqs
            rewrite_on_the_spot ct
              = do { let rhs_co = liftTcCoSubstWith [subst_tv] [subst_co] rhs
                         eq_co  = mkTcTyConAppCo eqTyCon $ 
-                                   [ mkTcReflCo (typeKind rhs)
+                                   [ mkTcReflCo (defaultKind $ typeKind rhs)
                                    , mkTcReflCo (mkTyVarTy tv)
                                    , mkTcSymCo rhs_co ]
                         new_rhs = pSnd (tcCoercionKind rhs_co)
@@ -754,7 +754,10 @@ interactWithInertsStage :: WorkItem -> TcS StopOrContinue
 -- react with anything at this stage. 
 interactWithInertsStage wi 
   = do { ctxt <- getTcSContext
-       ; if simplEqsOnly ctxt then 
+       ; if simplEqsOnly ctxt && not (isCFunEqCan wi) then 
+                    -- Why not just "simplEqsOnly"? Well our inert sets can't tolerate two family 
+                    -- equations with the /same/ head so we have to enable some reactions. The 
+                    -- example that breaks otherwise is indexed_types/should_compile/T2291.hs 
              return (ContinueWith wi)
          else 
            do { traceTcS "interactWithInerts" $ text "workitem = " <+> ppr wi
@@ -1564,18 +1567,19 @@ tryTopReact :: WorkItem -> TcS StopOrContinue
 tryTopReact wi 
  = do { inerts <- getTcSInerts
       ; ctxt   <- getTcSContext
-      ; if simplEqsOnly ctxt then return (ContinueWith wi) -- or Stop?
+      ; if simplEqsOnly ctxt then 
+          return (ContinueWith wi) 
         else 
           do { tir <- doTopReact inerts wi
-               ; case tir of 
-                   NoTopInt 
-                       -> return (ContinueWith wi)
-                   SomeTopInt rule what_next 
-                       -> do { bumpStepCountTcS 
-                             ; traceFireTcS (cc_depth wi) $
-                               ptext (sLit "Top react:") <+> text rule
-                             ; return what_next }
-               } }
+             ; case tir of 
+                 NoTopInt 
+                     -> return (ContinueWith wi)
+                 SomeTopInt rule what_next 
+                     -> do { bumpStepCountTcS 
+                           ; traceFireTcS (cc_depth wi) $
+                             ptext (sLit "Top react:") <+> text rule
+                           ; return what_next }
+             } }
 
 data TopInteractResult 
  = NoTopInt
@@ -1747,7 +1751,7 @@ lkpFunEqCache fam_head
                                                   
 
                ; let new_pty = mkTcEqPred (mkTyConApp tc xis_subst) xi_subst
-                     new_co  = mkTcTyConAppCo eqTyCon [ mkTcReflCo (typeKind xi_subst)
+                     new_co  = mkTcTyConAppCo eqTyCon [ mkTcReflCo (defaultKind $ typeKind xi_subst)
                                                       , mkTcTyConAppCo tc cos
                                                       , co ]
                                -- new_co :: (F xis_subst ~  xi_subst) ~ (F xis ~ xi)