[commit: ghc] ghc-8.0: Avoid recursive use of immSuperClasses (e37b571)

[git at git.haskell.org]

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

On branch  : ghc-8.0
Link       : http://ghc.haskell.org/trac/ghc/changeset/e37b571baabf18621eb3b471fddc015a021ecf46/ghc

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

commit e37b571baabf18621eb3b471fddc015a021ecf46
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Mon Jan 25 08:29:12 2016 +0000

    Avoid recursive use of immSuperClasses
    
    In fixing Trac #11480 I had omitted to deal with FunDeps.oclose,
    which was making recursive use of immSuperClasses, and hence
    going into a loop in the recursive case.
    
    Solution: use transSuperClasses, which takes care not to.
    (cherry picked from commit 42c6263f23cf3f00035389637862944e0594bc7a)


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

e37b571baabf18621eb3b471fddc015a021ecf46
 compiler/typecheck/FunDeps.hs        | 15 +++++++--------
 compiler/typecheck/TcType.hs         |  4 ++--
 testsuite/tests/polykinds/T11480a.hs |  2 +-
 3 files changed, 10 insertions(+), 11 deletions(-)

diff --git a/compiler/typecheck/FunDeps.hs b/compiler/typecheck/FunDeps.hs
index bf8c260..4e64d2e 100644
--- a/compiler/typecheck/FunDeps.hs
+++ b/compiler/typecheck/FunDeps.hs
@@ -23,7 +23,7 @@ import Name
 import Var
 import Class
 import Type
-import TcType( immSuperClasses )
+import TcType( transSuperClasses )
 import Unify
 import InstEnv
 import VarSet
@@ -516,18 +516,17 @@ oclose preds fixed_tvs
     tv_fds  :: [(TyCoVarSet,TyCoVarSet)]
     tv_fds  = [ (tyCoVarsOfTypes ls, tyCoVarsOfTypes rs)
               | pred <- preds
-              , (ls, rs) <- determined pred ]
+              , pred' <- pred : transSuperClasses pred
+                   -- Look for fundeps in superclasses too
+              , (ls, rs) <- determined pred' ]
 
     determined :: PredType -> [([Type],[Type])]
     determined pred
        = case classifyPredType pred of
             EqPred NomEq t1 t2 -> [([t1],[t2]), ([t2],[t1])]
-            ClassPred cls tys -> local_fds ++ concatMap determined superclasses
-              where
-               local_fds = [ instFD fd cls_tvs tys
-                           | fd <- cls_fds ]
-               (cls_tvs, cls_fds) = classTvsFds cls
-               superclasses = immSuperClasses cls tys
+            ClassPred cls tys  -> [ instFD fd cls_tvs tys
+                                  | let (cls_tvs, cls_fds) = classTvsFds cls
+                                  , fd <- cls_fds ]
             _ -> []
 
 {-
diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs
index 0182c02..8093a0c 100644
--- a/compiler/typecheck/TcType.hs
+++ b/compiler/typecheck/TcType.hs
@@ -1724,8 +1724,8 @@ mkMinimalBySCs ptys = go preds_with_scs []
    in_cloud p ps = or [ p `eqType` p' | (_, scs) <- ps, p' <- scs ]
 
 transSuperClasses :: PredType -> [PredType]
--- (transSuperClasses p) returns (p's superclasses)
--- not including p
+-- (transSuperClasses p) returns (p's superclasses) not including p
+-- Stop if you encounter the same class again
 -- See Note [Expanding superclasses]
 transSuperClasses p
   = go emptyNameSet p
diff --git a/testsuite/tests/polykinds/T11480a.hs b/testsuite/tests/polykinds/T11480a.hs
index 3d17168..eeeaf34 100644
--- a/testsuite/tests/polykinds/T11480a.hs
+++ b/testsuite/tests/polykinds/T11480a.hs
@@ -1,7 +1,7 @@
 {-# language KindSignatures, PolyKinds, TypeFamilies,
   NoImplicitPrelude, FlexibleContexts,
   MultiParamTypeClasses, GADTs,
-  ConstraintKinds, FlexibleInstances,
+  ConstraintKinds, FlexibleInstances, UndecidableInstances,
   FunctionalDependencies, UndecidableSuperClasses #-}
 
 module T11480a where