[commit: ghc] wip/new-flatten-skolems-Oct14: Fix the superclass-cycle detection code (Trac #9739) (87d89ea)

[git at git.haskell.org]

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

On branch  : wip/new-flatten-skolems-Oct14
Link       : http://ghc.haskell.org/trac/ghc/changeset/87d89ea120504fe7a93812ec1fc05935a8461f17/ghc

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

commit 87d89ea120504fe7a93812ec1fc05935a8461f17
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Fri Oct 31 12:31:59 2014 +0000

    Fix the superclass-cycle detection code (Trac #9739)
    
    We were falling into an infinite loop when doing the ambiguity
    check on a class method, even though we had previously detected
    a superclass cycle.  There was code to deal with this, but it
    wasn't right.


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

87d89ea120504fe7a93812ec1fc05935a8461f17
 compiler/typecheck/TcRnMonad.lhs                   |  3 ++
 compiler/typecheck/TcTyClsDecls.lhs                | 39 +++++++++++-----------
 testsuite/tests/typecheck/should_fail/T9739.hs     |  9 +++--
 testsuite/tests/typecheck/should_fail/T9739.stderr | 10 +++---
 4 files changed, 34 insertions(+), 27 deletions(-)

diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index dce4b49..cd41499 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -825,6 +825,9 @@ checkNoErrs main
             Just val -> return val
         }
 
+whenNoErrs :: TcM () -> TcM ()
+whenNoErrs thing = ifErrsM (return ()) thing
+
 ifErrsM :: TcRn r -> TcRn r -> TcRn r
 --      ifErrsM bale_out normal
 -- does 'bale_out' if there are errors in errors collection
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 50113db..5d610b4 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -1369,25 +1369,9 @@ since GADTs are not kind indexed.
 Validity checking is done once the mutually-recursive knot has been
 tied, so we can look at things freely.
 
-Note [Abort when superclass cycle is detected]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We must avoid doing the ambiguity check when there are already errors accumulated.
-This is because one of the errors may be a superclass cycle, and superclass cycles
-cause canonicalization to loop. Here is a representative example:
-
-  class D a => C a where
-    meth :: D a => ()
-  class C a => D a
-
-This fixes Trac #9415.
-
 \begin{code}
 checkClassCycleErrs :: Class -> TcM ()
-checkClassCycleErrs cls
-  = unless (null cls_cycles) $
-    do { mapM_ recClsErr cls_cycles
-       ; failM }  -- See Note [Abort when superclass cycle is detected]
-  where cls_cycles = calcClassCycles cls
+checkClassCycleErrs cls = mapM_ recClsErr (calcClassCycles cls)
 
 checkValidTyCl :: TyThing -> TcM ()
 checkValidTyCl thing
@@ -1640,8 +1624,11 @@ checkValidClass cls
           -- If there are superclass cycles, checkClassCycleErrs bails.
         ; checkClassCycleErrs cls
 
-        -- Check the class operations
-        ; mapM_ (check_op constrained_class_methods) op_stuff
+        -- Check the class operations.
+        -- But only if there have been no earlier errors
+        -- See Note [Abort when superclass cycle is detected]
+        ; whenNoErrs $
+          mapM_ (check_op constrained_class_methods) op_stuff
 
         -- Check the associated type defaults are well-formed and instantiated
         ; mapM_ check_at_defs at_stuff  }
@@ -1707,6 +1694,20 @@ checkFamFlag tc_name
                  2 (ptext (sLit "Use TypeFamilies to allow indexed type families"))
 \end{code}
 
+Note [Abort when superclass cycle is detected]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We must avoid doing the ambiguity check for the methods (in
+checkValidClass.check_op) when there are already errors accumulated.
+This is because one of the errors may be a superclass cycle, and
+superclass cycles cause canonicalization to loop. Here is a
+representative example:
+
+  class D a => C a where
+    meth :: D a => ()
+  class C a => D a
+
+This fixes Trac #9415, #9739
+
 %************************************************************************
 %*                                                                      *
                 Checking role validity
diff --git a/testsuite/tests/typecheck/should_fail/T9739.hs b/testsuite/tests/typecheck/should_fail/T9739.hs
index 4b7869d..18df797 100644
--- a/testsuite/tests/typecheck/should_fail/T9739.hs
+++ b/testsuite/tests/typecheck/should_fail/T9739.hs
@@ -1,6 +1,9 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
 module T9739 where
 
-class Class2 a => Class1 a where
-  class3 :: (Class2 a) => b
+class Class3 a => Class1 a where
 
-class (Class1 a) => Class2 a where
+class Class2 t a where
+  class2 :: (Class3 t) => a -> m
+
+class (Class1 t, Class2 t t) => Class3 t where
diff --git a/testsuite/tests/typecheck/should_fail/T9739.stderr b/testsuite/tests/typecheck/should_fail/T9739.stderr
index 95fcf6a..34e2f11 100644
--- a/testsuite/tests/typecheck/should_fail/T9739.stderr
+++ b/testsuite/tests/typecheck/should_fail/T9739.stderr
@@ -1,10 +1,10 @@
 
-T9739.hs:3:1:
+T9739.hs:4:1:
     Cycle in class declaration (via superclasses):
-      Class1 -> Class2 -> Class1
+      Class1 -> Class3 -> Class1
     In the class declaration for ‘Class1’
 
-T9739.hs:6:1:
+T9739.hs:9:1:
     Cycle in class declaration (via superclasses):
-      Class2 -> Class1 -> Class2
-    In the class declaration for ‘Class2’
+      Class3 -> Class1 -> Class3
+    In the class declaration for ‘Class3’