Special-case implicit params in superclass expansion

This issue came up in Trac #11480, and is documented in
Note [When superclasses help] in TcRnTypes.

We were getting a spurious warning
  T11480.hs:1:1: warning:
     solveWanteds: too many iterations (limit = 4)

The fix is easy.  A bit of refactoring along the way.

The original bug report in Trac #11480 appears to work
fine in HEAD and the 8.0 branch but I added a regression
test in this commit as well.

8 files changed, 118 insertions, 32 deletions

diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs
index d0c36261e3..5dc35ac185 100644
--- a/compiler/typecheck/TcCanonical.hs
+++ b/compiler/typecheck/TcCanonical.hs
@@ -260,11 +260,12 @@ So here's the plan:
    in solveSimpleGivens or solveSimpleWanteds.
    See Note [Danger of adding superclasses during solving]
 
-3. If we have any remaining unsolved wanteds, try harder:
-   take both the Givens and Wanteds, and expand superclasses again.
-   This may succeed in generating (a finite number of) extra Givens,
-   and extra Deriveds. Both may help the proof.
-   This is done in TcSimplify.expandSuperClasses.
+3. If we have any remaining unsolved wanteds
+        (see Note [When superclasses help] in TcRnTypes)
+   try harder: take both the Givens and Wanteds, and expand
+   superclasses again.  This may succeed in generating (a finite
+   number of) extra Givens, and extra Deriveds. Both may help the
+   proof.  This is done in TcSimplify.expandSuperClasses.
 
 4. Go round to (2) again.  This loop (2,3,4) is implemented
    in TcSimplify.simpl_loop.
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index d7670f1ba1..ba07cf161d 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -66,6 +66,7 @@ module TcRnTypes(
         Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, pprCts,
         singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList,
         isEmptyCts, isCTyEqCan, isCFunEqCan,
+        isPendingScDict, superClassesMightHelp,
         isCDictCan_Maybe, isCFunEqCan_maybe,
         isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt,
         isGivenCt, isHoleCt, isOutOfScopeCt, isExprHoleCt, isTypeHoleCt,
@@ -1526,12 +1527,18 @@ ctFlavour = ctEvFlavour . ctEvidence
 ctEqRel :: Ct -> EqRel
 ctEqRel = ctEvEqRel . ctEvidence
 
-dropDerivedWC :: WantedConstraints -> WantedConstraints
--- See Note [Dropping derived constraints]
-dropDerivedWC wc@(WC { wc_simple = simples, wc_insol = insols })
-  = wc { wc_simple = dropDerivedSimples simples
-       , wc_insol  = dropDerivedInsols insols }
-    -- The wc_impl implications are already (recursively) filtered
+instance Outputable Ct where
+  ppr ct = ppr (cc_ev ct) <+> parens pp_sort
+    where
+      pp_sort = case ct of
+         CTyEqCan {}      -> text "CTyEqCan"
+         CFunEqCan {}     -> text "CFunEqCan"
+         CNonCanonical {} -> text "CNonCanonical"
+         CDictCan { cc_pend_sc = pend_sc }
+            | pend_sc   -> text "CDictCan(psc)"
+            | otherwise -> text "CDictCan"
+         CIrredEvCan {}   -> text "CIrredEvCan"
+         CHoleCan { cc_occ = occ } -> text "CHoleCan:" <+> ppr occ
 
 {-
 ************************************************************************
@@ -1754,6 +1761,11 @@ isUserTypeErrorCt ct = case getUserTypeErrorMsg ct of
                          Just _ -> True
                          _      -> False
 
+isPendingScDict :: Ct -> Maybe Ct
+isPendingScDict ct@(CDictCan { cc_pend_sc = True })
+                  = Just (ct { cc_pend_sc = False })
+isPendingScDict _ = Nothing
+
 -- | Are we looking at an Implicit CallStack
 -- (i.e. @IP "name" CallStack@)?
 --
@@ -1768,18 +1780,44 @@ isCallStackDict cls tys
 isCallStackDict _ _
   = Nothing
 
-instance Outputable Ct where
-  ppr ct = ppr (cc_ev ct) <+> parens pp_sort
-    where
-      pp_sort = case ct of
-         CTyEqCan {}      -> text "CTyEqCan"
-         CFunEqCan {}     -> text "CFunEqCan"
-         CNonCanonical {} -> text "CNonCanonical"
-         CDictCan { cc_pend_sc = pend_sc }
-            | pend_sc   -> text "CDictCan(psc)"
-            | otherwise -> text "CDictCan"
-         CIrredEvCan {}   -> text "CIrredEvCan"
-         CHoleCan { cc_occ = occ } -> text "CHoleCan:" <+> ppr occ
+superClassesMightHelp :: Ct -> Bool
+-- ^ True if taking superclasses of givens, or of wanteds (to perhaps
+-- expose more equalities or functional dependencies) might help to
+-- solve this constraint.  See Note [When superclases help]
+superClassesMightHelp ct
+  | CDictCan { cc_class = cls } <- ct
+  , cls `hasKey` ipClassKey
+  = False
+  | otherwise
+  = True
+
+{- Note [When superclasses help]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+First read Note [The superclass story] in TcCanonical.
+
+We expand superclasses and iterate only if there is at unsolved wanted
+for which expansion of superclasses (e.g. from given constraints)
+might actually help. Usually the answer is "yes" but for implicit
+paramters it is "no".  If we have [W] ?x::ty, expanding superclasses
+won't help:
+  - Superclasses can't be implicit parameters
+  - If we have a [G] ?x:ty2, then we'll have another unsolved
+      [D] ty ~ ty2 (from the functional dependency)
+    which will trigger superclass expansion.
+
+It's a bit of a special case, but it's easy to do.  The runtime cost
+is low because the unsolved set is usually empty anyway (errors
+aside), and the first non-imlicit-parameter will terminate the search.
+
+The special case is worth it (Trac #11480, comment:2) because it
+applies to CallStack constraints, which aren't type errors. If we have
+   f :: (C a) => blah
+   f x = ...undefined...
+we'll get a CallStack constraint.  If that's the only unsolved constraint
+it'll eventually be solved by defaulting.  So we don't want to emit warnings
+about hitting the simplifier's iteration limit.  A CallStack constraint
+really isn't an unsolved constraint; it can always be solved by defaulting.
+-}
 
 singleCt :: Ct -> Cts
 singleCt = unitBag
@@ -1885,6 +1923,13 @@ addInsols :: WantedConstraints -> Bag Ct -> WantedConstraints
 addInsols wc cts
   = wc { wc_insol = wc_insol wc `unionBags` cts }
 
+dropDerivedWC :: WantedConstraints -> WantedConstraints
+-- See Note [Dropping derived constraints]
+dropDerivedWC wc@(WC { wc_simple = simples, wc_insol = insols })
+  = wc { wc_simple = dropDerivedSimples simples
+       , wc_insol  = dropDerivedInsols insols }
+    -- The wc_impl implications are already (recursively) filtered
+
 isInsolubleStatus :: ImplicStatus -> Bool
 isInsolubleStatus IC_Insoluble = True
 isInsolubleStatus _            = False
diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs
index 44e9a03203..3616bb7a6d 100644
--- a/compiler/typecheck/TcSMonad.hs
+++ b/compiler/typecheck/TcSMonad.hs
@@ -53,7 +53,7 @@ module TcSMonad (
     emptyInert, getTcSInerts, setTcSInerts, takeGivenInsolubles,
     matchableGivens, prohibitedSuperClassSolve,
     getUnsolvedInerts,
-    removeInertCts, getPendingScDicts, isPendingScDict,
+    removeInertCts, getPendingScDicts,
     addInertCan, addInertEq, insertFunEq,
     emitInsoluble, emitWorkNC,
 
@@ -1698,16 +1698,13 @@ getPendingScDicts = updRetInertCans get_sc_dicts
         = addDict dicts cls tys ct
     add ct _ = pprPanic "getPendingScDicts" (ppr ct)
 
-isPendingScDict :: Ct -> Maybe Ct
-isPendingScDict ct@(CDictCan { cc_pend_sc = True })
-                  = Just (ct { cc_pend_sc = False })
-isPendingScDict _ = Nothing
-
 getUnsolvedInerts :: TcS ( Bag Implication
                          , Cts     -- Tyvar eqs: a ~ ty
                          , Cts     -- Fun eqs:   F a ~ ty
                          , Cts     -- Insoluble
                          , Cts )   -- All others
+-- Return all the unsolved [Wanted] or [Derived] constraints
+--
 -- Post-condition: the returned simple constraints are all fully zonked
 --                     (because they come from the inert set)
 --                 the unsolved implics may not be
diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs
index 499b53a7da..479893a20f 100644
--- a/compiler/typecheck/TcSimplify.hs
+++ b/compiler/typecheck/TcSimplify.hs
@@ -1059,20 +1059,26 @@ expandSuperClasses :: WantedConstraints -> TcS (Bool, WantedConstraints)
 -- unsolved wanteds or givens
 -- See Note [The superclass story] in TcCanonical
 expandSuperClasses wc@(WC { wc_simple = unsolved, wc_insol = insols })
-  | isEmptyBag unsolved  -- No unsolved simple wanteds, so do not add suerpclasses
+  | not (anyBag superClassesMightHelp unsolved)
   = return (True, wc)
   | otherwise
-  = do { let (pending_wanted, unsolved') = mapAccumBagL get [] unsolved
+  = do { traceTcS "expandSuperClasses {" empty
+       ; let (pending_wanted, unsolved') = mapAccumBagL get [] unsolved
              get acc ct = case isPendingScDict ct of
                             Just ct' -> (ct':acc, ct')
                             Nothing  -> (acc,     ct)
        ; pending_given <- getPendingScDicts
        ; if null pending_given && null pending_wanted
-         then return (True, wc)
+         then do { traceTcS "End expandSuperClasses no-op }" empty
+                 ; return (True, wc) }
          else
     do { new_given  <- makeSuperClasses pending_given
        ; new_insols <- solveSimpleGivens new_given
        ; new_wanted <- makeSuperClasses pending_wanted
+       ; traceTcS "End expandSuperClasses }"
+                  (vcat [ text "Given:" <+> ppr pending_given
+                        , text "Insols from given:" <+> ppr new_insols
+                        , text "Wanted:" <+> ppr new_wanted ])
        ; return (False, wc { wc_simple = unsolved' `unionBags` listToBag new_wanted
                            , wc_insol = insols `unionBags` new_insols }) } }
 
diff --git a/testsuite/tests/polykinds/T11480a.hs b/testsuite/tests/polykinds/T11480a.hs
new file mode 100644
index 0000000000..3d17168082
--- /dev/null
+++ b/testsuite/tests/polykinds/T11480a.hs
@@ -0,0 +1,26 @@
+{-# language KindSignatures, PolyKinds, TypeFamilies,
+  NoImplicitPrelude, FlexibleContexts,
+  MultiParamTypeClasses, GADTs,
+  ConstraintKinds, FlexibleInstances,
+  FunctionalDependencies, UndecidableSuperClasses #-}
+
+module T11480a where
+
+import GHC.Types (Constraint)
+import qualified Prelude
+
+data Nat (c :: i -> i -> *) (d :: j -> j -> *) (f :: i -> j) (g :: i -> j)
+
+class Functor p (Nat p (->)) p => Category (p :: i -> i -> *)
+
+class (Category dom, Category cod)
+   => Functor (dom :: i -> i -> *) (cod :: j -> j -> *) (f :: i -> j)
+    | f -> dom cod
+
+instance (Category c, Category d) => Category (Nat c d)
+instance (Category c, Category d) => Functor (Nat c d) (Nat (Nat c d) (->)) (Nat c d)
+instance (Category c, Category d) => Functor (Nat c d) (->) (Nat c d f)
+
+instance Category (->)
+instance Functor (->) (->) ((->) e)
+instance Functor (->) (Nat (->) (->)) (->)
diff --git a/testsuite/tests/polykinds/all.T b/testsuite/tests/polykinds/all.T
index f1f25cecc4..69c5ba0790 100644
--- a/testsuite/tests/polykinds/all.T
+++ b/testsuite/tests/polykinds/all.T
@@ -134,3 +134,4 @@ test('T11278', normal, compile, [''])
 test('T11255', normal, compile, [''])
 test('T11459', normal, compile_fail, [''])
 test('T11466', normal, compile_fail, [''])
+test('T11480a', normal, compile, [''])
diff --git a/testsuite/tests/typecheck/should_compile/T11480.hs b/testsuite/tests/typecheck/should_compile/T11480.hs
new file mode 100644
index 0000000000..c6aafd6687
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T11480.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE FlexibleContexts, UndecidableSuperClasses #-}
+
+module T11480 where
+
+class C [a] => D a
+class D a => C a
+
+foo :: C a => a -> a
+foo = undefined
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index eb4f1fb1b9..5975ed0fe9 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -497,3 +497,4 @@ test('T11462',
      ['', [('T11462_Plugin.hs', '-package ghc'),
            ('T11462.hs', '')],
       '-dynamic'])
+test('T11480', normal, compile, [''])