From 8a680445dbd48735792e1f29ceec168ff59df3fd Mon Sep 17 00:00:00 2001
From: Manuel M T Chakravarty <chak@cse.unsw.edu.au>
Date: Mon, 29 Sep 2008 14:10:40 +0000
Subject: [PATCH] Type families: consider subst rules both way -
 applySubstFam, applySubstVarVar & applySubstVarFam need to
 return their   second argument -to be put into the todo
 list- if the rule would be   applicable if the equalities
 would be supplied in the opposite order.

MERGE TO 6.10
---
 compiler/typecheck/TcTyFuns.lhs |   34 ++++++++++++++++++++++++++++++++--
 1 file changed, 32 insertions(+), 2 deletions(-)

diff --git a/compiler/typecheck/TcTyFuns.lhs b/compiler/typecheck/TcTyFuns.lhs
index 5e7814c..55243e9 100644
--- a/compiler/typecheck/TcTyFuns.lhs
+++ b/compiler/typecheck/TcTyFuns.lhs
@@ -884,8 +884,11 @@ mapSubstRules eq eqs
        }
   where
     substRules eq1 eq2
-      = do {   -- try the SubstFam rule
-             optEqs <- applySubstFam eq1 eq2
+      = do {traceTc $ hang (ptext (sLit "Trying subst rules with"))
+                        4 (ppr eq1 $$ ppr eq2)
+
+               -- try the SubstFam rule
+           ; optEqs <- applySubstFam eq1 eq2
            ; case optEqs of
                Just (eqs, skolems) -> return (eqs, [], skolems)
                Nothing             -> do 
@@ -953,6 +956,8 @@ applySubstFam :: RewriteInst
               -> TcM (Maybe ([RewriteInst], TyVarSet))
 applySubstFam eq1@(RewriteFam {rwi_fam = fam1, rwi_args = args1})
               eq2@(RewriteFam {rwi_fam = fam2, rwi_args = args2})
+
+    -- rule matches => rewrite
   | fam1 == fam2 && tcEqTypes args1 args2 &&
     (isWantedRewriteInst eq2 || not (isWantedRewriteInst eq1))
 -- !!!TODO: tcEqTypes is insufficient as it does not look through type synonyms
@@ -962,11 +967,18 @@ applySubstFam eq1@(RewriteFam {rwi_fam = fam1, rwi_args = args1})
        ; eq2' <- deriveEqInst eq2 lhs rhs co2'
        ; liftM Just $ normEqInst eq2'
        }
+
+    -- rule would match with eq1 and eq2 swapped => put eq2 into todo list
+  | fam1 == fam2 && tcEqTypes args1 args2 &&
+    (isWantedRewriteInst eq1 || not (isWantedRewriteInst eq2))
+  = return $ Just ([eq2], emptyVarSet)
+
   where
     lhs = rwi_right eq1
     rhs = rwi_right eq2
     co1 = eqInstCoType (rwi_co eq1)
     co2 = rwi_co eq2
+
 applySubstFam _ _ = return Nothing
 \end{code}
 
@@ -988,17 +1000,26 @@ applySubstVarVar :: RewriteInst
                  -> TcM (Maybe ([RewriteInst], TyVarSet))
 applySubstVarVar eq1@(RewriteVar {rwi_var = tv1})
                  eq2@(RewriteVar {rwi_var = tv2})
+
+    -- rule matches => rewrite
   | tv1 == tv2 &&
     (isWantedRewriteInst eq2 || not (isWantedRewriteInst eq1))
   = do { co2' <- mkRightTransEqInstCo co2 co1 (lhs, rhs)
        ; eq2' <- deriveEqInst eq2 lhs rhs co2'
        ; liftM Just $ normEqInst eq2'
        }
+
+    -- rule would match with eq1 and eq2 swapped => put eq2 into todo list
+  | tv1 == tv2 &&
+    (isWantedRewriteInst eq1 || not (isWantedRewriteInst eq2))
+  = return $ Just ([eq2], emptyVarSet)
+
   where
     lhs = rwi_right eq1
     rhs = rwi_right eq2
     co1 = eqInstCoType (rwi_co eq1)
     co2 = rwi_co eq2
+
 applySubstVarVar _ _ = return Nothing
 \end{code}
 
@@ -1016,6 +1037,8 @@ co2' is returned.  (The equality co1 is not returned as it remain unaltered.)
 
 \begin{code}
 applySubstVarFam :: RewriteInst -> RewriteInst -> TcM (Maybe RewriteInst)
+
+  -- rule matches => rewrite
 applySubstVarFam eq1@(RewriteVar {rwi_var = tv1})
                  eq2@(RewriteFam {rwi_fam = fam2, rwi_args = args2})
   | tv1 `elemVarSet` tyVarsOfTypes args2
@@ -1030,6 +1053,13 @@ applySubstVarFam eq1@(RewriteVar {rwi_var = tv1})
     rhs2 = rwi_right eq2
     co1  = eqInstCoType (rwi_co eq1)
     co2  = rwi_co eq2
+
+  -- rule would match with eq1 and eq2 swapped => put eq2 into todo list
+applySubstVarFam eq1@(RewriteFam {rwi_fam = fam1, rwi_args = args1})
+                 eq2@(RewriteVar {rwi_var = tv2})
+  | tv2 `elemVarSet` tyVarsOfTypes args1
+  = return $ Just eq2
+
 applySubstVarFam _ _ = return Nothing
 \end{code}
 
-- 
1.7.10.4