Deal more correctly with orphan instances

[ghc-hetmet.git] / compiler / specialise / Rules.lhs

diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs
index 6fc35a5..4b7e926 100644 (file)
--- a/compiler/specialise/Rules.lhs
+++ b/compiler/specialise/Rules.lhs
@@ -91,7 +91,7 @@ mkLocalRule name act fn bndrs args rhs
   = Rule { ru_name = name, ru_fn = fn, ru_act = act,
           ru_bndrs = bndrs, ru_args = args,
           ru_rhs = rhs, ru_rough = roughTopNames args,
-          ru_orph = Just (nameOccName fn), ru_local = True }
+          ru_local = True }
 
 --------------
 roughTopNames :: [CoreExpr] -> [Maybe Name]
@@ -348,19 +348,25 @@ matchN in_scope tmpl_vars tmpl_es target_es
                                Just e -> e
                                other  -> unbound tmpl_var'
  
-    unbound var = pprPanic "Template variable unbound in rewrite rule" (ppr var)
+    unbound var = pprPanic "Template variable unbound in rewrite rule" 
+                       (ppr var $$ ppr tmpl_vars $$ ppr tmpl_vars' $$ ppr tmpl_es $$ ppr target_es)
 \end{code}
 
 Note [Template binders]
 ~~~~~~~~~~~~~~~~~~~~~~~
 Consider the following match:
        Template:  forall x.  f x 
-       Taret:     f (x+1)
-This should succeed, because the template variable 'x' has nothing to do with
-the 'x' in the target.
+       Target:     f (x+1)
+This should succeed, because the template variable 'x' has 
+nothing to do with the 'x' in the target. 
 
-To achive this, we use rnBndrL to rename the template variables if necessary;
-the renamed ones are the tmpl_vars'
+On reflection, this case probably does just work, but this might not
+       Template:  forall x. f (\x.x) 
+       Target:    f (\y.y)
+Here we want to clone when we find the \x, but to know that x must be in scope
+
+To achive this, we use rnBndrL to rename the template variables if
+necessary; the renamed ones are the tmpl_vars'
 
 
        ---------------------------------------------
@@ -591,7 +597,7 @@ match_var menv subst@(tv_subst, id_subst, binds) v1 e2
                | otherwise     -- No renaming to do on e2
                -> Just (tv_subst, extendVarEnv id_subst v1' e2, binds)
 
-       Just e2' | tcEqExprX (nukeRnEnvL rn_env) e2' e2 
+       Just e1' | tcEqExprX (nukeRnEnvL rn_env) e1' e2 
                 -> Just subst
 
                 | otherwise