Constraint simplification loop now depends on `ExpansionFuel`wip/T21909

instead of a boolean flag for `CDictCan.cc_pend_sc`.
Pending givens get a fuel of 3 while Wanted and quantified constraints get a fuel of 1.
This helps pending given constraints to keep up with pending wanted constraints in case of
`UndecidableSuperClasses` and superclass expansions while simplifying the infered type.

Adds 3 dynamic flags for controlling the fuels for each type of constraints
`-fgivens-expansion-fuel` for givens `-fwanteds-expansion-fuel` for wanteds and `-fqcs-expansion-fuel` for quantified constraints

Fixes #21909
Added Tests T21909, T21909b
Added Note [Expanding Recursive Superclasses and ExpansionFuel]

1 files changed, 21 insertions, 14 deletions

diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs
index ad4e10ebf6..5fdd4df702 100644
--- a/compiler/GHC/Tc/Solver/Monad.hs
+++ b/compiler/GHC/Tc/Solver/Monad.hs
@@ -513,10 +513,13 @@ getInertGivens
        ; return (filter isGivenCt all_cts) }
 
 getPendingGivenScs :: TcS [Ct]
--- Find all inert Given dictionaries, or quantified constraints,
---     whose cc_pend_sc flag is True
---     and that belong to the current level
--- Set their cc_pend_sc flag to False in the inert set, and return that Ct
+-- Find all inert Given dictionaries, or quantified constraints, such that
+--     1. cc_pend_sc flag has fuel strictly > 0
+--     2. belongs to the current level
+-- For each such dictionary:
+-- * Return it (with unmodified cc_pend_sc) in sc_pending
+-- * Modify the dict in the inert set to have cc_pend_sc = doNotExpand
+--   to record that we have expanded superclasses for this dict
 getPendingGivenScs = do { lvl <- getTcLevel
                         ; updRetInertCans (get_sc_pending lvl) }
 
@@ -530,29 +533,33 @@ get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts })
     sc_pending = sc_pend_insts ++ sc_pend_dicts
 
     sc_pend_dicts = foldDicts get_pending dicts []
-    dicts' = foldr add dicts sc_pend_dicts
+    dicts' = foldr exhaustAndAdd dicts sc_pend_dicts
 
     (sc_pend_insts, insts') = mapAccumL get_pending_inst [] insts
 
-    get_pending :: Ct -> [Ct] -> [Ct]  -- Get dicts with cc_pend_sc = True
-                                       -- but flipping the flag
+    get_pending :: Ct -> [Ct] -> [Ct]  -- Get dicts with cc_pend_sc > 0
     get_pending dict dicts
-        | Just dict' <- pendingScDict_maybe dict
+        | isPendingScDict dict
         , belongs_to_this_level (ctEvidence dict)
-        = dict' : dicts
+        = dict : dicts
         | otherwise
         = dicts
 
-    add :: Ct -> DictMap Ct -> DictMap Ct
-    add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts
-        = addDict dicts cls tys ct
-    add ct _ = pprPanic "getPendingScDicts" (ppr ct)
+    exhaustAndAdd :: Ct -> DictMap Ct -> DictMap Ct
+    exhaustAndAdd ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts
+    -- exhaust the fuel for this constraint before adding it as
+    -- we don't want to expand these constraints again
+        = addDict dicts cls tys (ct {cc_pend_sc = doNotExpand})
+    exhaustAndAdd ct _ = pprPanic "getPendingScDicts" (ppr ct)
 
     get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst)
     get_pending_inst cts qci@(QCI { qci_ev = ev })
        | Just qci' <- pendingScInst_maybe qci
        , belongs_to_this_level ev
-       = (CQuantCan qci' : cts, qci')
+       = (CQuantCan qci : cts, qci')
+       -- qci' have their fuel exhausted
+       -- we don't want to expand these constraints again
+       -- qci is expanded
        | otherwise
        = (cts, qci)