Be more careful in GHC.Tc.Solver.Interact.solveOneFromTheOther

We were failing to account for the cc_pend_sc flag in this
important function, with the result that we expanded superclasses
forever.

Fixes #22516.

2 files changed, 92 insertions, 0 deletions

diff --git a/testsuite/tests/typecheck/should_compile/T22516.hs b/testsuite/tests/typecheck/should_compile/T22516.hs
new file mode 100644
index 0000000000..6bc481d3ee
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T22516.hs
@@ -0,0 +1,91 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE UndecidableSuperClasses #-}
+module Bug where
+
+import Data.Kind (Constraint, Type)
+
+data D a
+
+f :: Generic (D a) => ()
+f = ()
+
+type family
+  AllF (c :: k -> Constraint) (xs :: [k]) :: Constraint where
+  AllF _c '[]       = ()
+  AllF  c (x ': xs) = (c x, All c xs)
+
+class (AllF c xs, SListI xs) => All (c :: k -> Constraint) (xs :: [k]) where
+
+type SListI = All Top
+
+class Top x
+instance Top x
+
+class All SListI (Code a) => Generic a where
+  type Code a :: [[Type]]
+
+
+{-
+  final wc = WC {wc_impl =
+                   Implic {
+                     TcLevel = 1
+                     Skolems = k_aG9[sk:1] (a_aGa[sk:1] :: k_aG9[sk:1])
+                     Given-eqs = LocalGivenEqs
+                     Status = Unsolved
+                     Given = $dGeneric_aGb :: Generic (D a_aGa[sk:1])
+                     Wanted =
+                       WC {wc_simple =
+                             [W] irred_aGo {0}:: AllF
+                                                   SListI (Code (D a_aGe[tau:1])) (CIrredCan(irred))
+                             [W] irred_aGu {0}:: AllF
+                                                   Top (Code (D a_aGe[tau:1])) (CIrredCan(irred))
+                             [W] $dGeneric_aGf {0}:: Generic (D a_aGe[tau:1]) (CDictCan)
+                             [W] $dAll_aGn {0}:: All SListI (Code (D a_aGe[tau:1])) (CDictCan)
+                             [W] $dAll_aGv {0}:: All
+                                                   Top (Code (D a_aGe[tau:1])) (CDictCan(psc))}
+                     Binds = EvBindsVar<aGg>
+                     the type signature for:
+                       f :: forall {k} (a :: k). Generic (D a) => () }}
+
+
+
+--------------------------
+-- Given
+[G] Generic (D a)
+==> superclass
+[G] All SListI (Code (D a))   =  All (All Top) (Code (D a))
+==> superclass
+[G] AllF SLIstI (Code (D a))  =  AllF (All Top) (Code (D a))
+[G] SListI (Code (D a))       =  All Top (Code (D a))    {loop}
+
+Next iteration
+===>
+[G] AllF Top (Code (D a))
+[G] SListI (Code (D a))       = All Top (Code (D a))  (already there)
+
+--------------------------
+-- Wanted
+[W] Generic (D a)
+==> superclass
+[W] All SListI (Code (D a))   =  All (All Top) (Code (D a))
+==> superclass
+[W] AllF SLIstI (Code (D a))  =  AllF (All Top) (Code (D a))
+[W] SListI (Code (D a))       =  All Top (Code (D a))    {loop}
+
+Next iteration
+===>
+[W] AllF Top (Code (D a))
+[W] SListI (Code (D a))       = All Top (Code (D a))  (already there)
+
+-}
\ No newline at end of file
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index 6413034c05..1f1e7d8d1f 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -852,3 +852,4 @@ test('T21951b', normal, compile, ['-Wredundant-strictness-flags'])
 test('T21550', normal, compile, [''])
 test('T22310', normal, compile, [''])
 test('T22331', normal, compile, [''])
+test('T22516', normal, compile, [''])