[commit: ghc] master: Fix canIrredPred again (1e0ef82)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/1e0ef8265d67d05e5114310311804b6d51bec7dd/ghc

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

commit 1e0ef8265d67d05e5114310311804b6d51bec7dd
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Fri Nov 15 18:47:38 2013 +0000

    Fix canIrredPred again
    
    This follows up the earlier patch to Trac #6068, which I
    obviously hadn't validated properly.


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

1e0ef8265d67d05e5114310311804b6d51bec7dd
 compiler/typecheck/TcCanonical.lhs |   33 +++++++++++++++++++++++----------
 1 file changed, 23 insertions(+), 10 deletions(-)

diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs
index cc3c042..1850fdf 100644
--- a/compiler/typecheck/TcCanonical.lhs
+++ b/compiler/typecheck/TcCanonical.lhs
@@ -377,22 +377,35 @@ is_improvement_pty ty = go (classifyPredType ty)
 \begin{code}
 canIrred :: CtLoc -> CtEvidence -> TcS StopOrContinue
 -- Precondition: ty not a tuple and no other evidence form
-canIrred d ev
-  = do { let ty = ctEvPred ev
-       ; traceTcS "can_pred" (text "IrredPred = " <+> ppr ty)
-       ; (xi,co) <- flatten d FMFullFlatten ev ty -- co :: xi ~ ty
-       ; mb <- rewriteCtFlavor ev xi co
+canIrred d old_ev
+  = do { let old_ty = ctEvPred old_ev
+       ; traceTcS "can_pred" (text "IrredPred = " <+> ppr old_ty)
+       ; (xi,co) <- flatten d FMFullFlatten old_ev old_ty -- co :: xi ~ old_ty
+       ; mb <- rewriteCtFlavor old_ev xi co
        ; case mb of {
              Nothing     -> return Stop ;
              Just new_ev ->
 
     do { -- Re-classify, in case flattening has improved its shape
        ; case classifyPredType (ctEvPred new_ev) of
-           ClassPred cls tys -> canClassNC d ev cls tys
-           EqPred ty1 ty2    -> canEqNC    d ev ty1 ty2
-           TuplePred tys     -> canTuple   d ev tys
-           IrredPred {}      -> continueWith $
-                                CIrredEvCan { cc_ev = new_ev, cc_loc = d } } } }
+           ClassPred cls tys -> canClassNC d new_ev cls tys
+           TuplePred tys     -> canTuple   d new_ev tys
+           EqPred ty1 ty2
+              | something_changed old_ty ty1 ty2 -> canEqNC d new_ev ty1 ty2
+           _  -> continueWith $
+                 CIrredEvCan { cc_ev = new_ev, cc_loc = d } } } }
+  where
+    -- If the constraint was a kind-mis-matched equality, we must
+    -- retry canEqNC only if something has changed, otherwise we
+    -- get an infinite loop
+    something_changed old_ty new_ty1 new_ty2
+       | EqPred old_ty1 old_ty2 <- classifyPredType old_ty
+       = not (            new_ty1 `eqType`          old_ty1
+              && typeKind new_ty1 `eqKind` typeKind old_ty1
+              &&          new_ty2 `eqType`          old_ty2
+              && typeKind new_ty2 `eqKind` typeKind old_ty2)
+       | otherwise
+       = True
 
 canHole :: CtLoc -> CtEvidence -> OccName -> TcS StopOrContinue
 canHole d ev occ