[Git][ghc/ghc][wip/T22194-flags] Allow quantification over equalities at top level (only)

[Simon Peyton Jones (@simonpj)]

Simon Peyton Jones pushed to branch wip/T22194-flags at Glasgow Haskell Compiler / GHC


Commits:
c0b32576 by Simon Peyton Jones at 2023-03-29T22:56:36+01:00
Allow quantification over equalities at top level (only)

- - - - -


1 changed file:

- compiler/GHC/Tc/Solver.hs


Changes:

=====================================
compiler/GHC/Tc/Solver.hs
=====================================
@@ -1705,7 +1705,8 @@ decidePromotedTyVars :: InferMode
 -- Also return CoVars that appear free in the final quantified types
 --   we can't quantify over these, and we must make sure they are in scope
 decidePromotedTyVars infer_mode name_taus psigs candidates
-  = do { (no_quant, maybe_quant) <- pick infer_mode candidates
+  = do { tc_lvl <- TcM.getTcLevel
+       ; (no_quant, maybe_quant) <- pick infer_mode (not (isTopTcLevel tc_lvl)) candidates
 
        -- If possible, we quantify over partial-sig qtvs, so they are
        -- not mono. Need to zonk them because they are meta-tyvar TyVarTvs
@@ -1717,7 +1718,6 @@ decidePromotedTyVars infer_mode name_taus psigs candidates
 
        ; taus <- mapM (TcM.zonkTcType . snd) name_taus
 
-       ; tc_lvl <- TcM.getTcLevel
        ; let psig_tys = mkTyVarTys psig_qtvs ++ psig_theta
 
              -- (b) The co_var_tvs are tvs mentioned in the types of covars or
@@ -1806,29 +1806,31 @@ decidePromotedTyVars infer_mode name_taus psigs candidates
 
        ; return (maybe_quant, co_vars) }
   where
-    pick :: InferMode -> [PredType] -> TcM ([PredType], [PredType])
+    pick :: InferMode -> Bool -> [PredType] -> TcM ([PredType], [PredType])
     -- Split the candidates into ones we definitely
     -- won't quantify, and ones that we might
-    pick ApplyMR         cand = return (cand, [])
-    pick NoRestrictions  cand = return (partition is_eq cand)
-    pick EagerDefaulting cand = do { os <- xoptM LangExt.OverloadedStrings
-                                   ; return (partition (is_int_ct os) cand) }
+    pick ApplyMR         _      cand = return (cand, [])
+    pick NoRestrictions  nested cand = return (partition (is_eq nested) cand)
+    pick EagerDefaulting nested cand = do { os <- xoptM LangExt.OverloadedStrings
+                                          ; return (partition (is_int_ct nested os) cand) }
+
+    -- These functions return True for a constraint we should /not/ quantify
 
     -- For EagerDefaulting, do not quantify over
     -- over any interactive class constraint
-    is_int_ct ovl_strings pred
+    is_int_ct nested ovl_strings pred
       = case classifyPredType pred of
            ClassPred cls _ -> isInteractiveClass ovl_strings cls
-           EqPred {}       -> True
-           IrredPred {}    -> True
-           ForAllPred {}   -> True
+           EqPred {}       -> nested
+           IrredPred {}    -> nested
+           ForAllPred {}   -> nested
 
-    is_eq pred
+    is_eq nested pred
       = case classifyPredType pred of
            ClassPred {}  -> False
-           EqPred {}     -> True
-           IrredPred {}  -> True
-           ForAllPred {} -> True
+           EqPred {}     -> nested
+           IrredPred {}  -> nested
+           ForAllPred {} -> nested
 
 -------------------
 defaultTyVarsAndSimplify :: TcLevel



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c0b325769f19dda81cad82de768e9f8563ec8273

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c0b325769f19dda81cad82de768e9f8563ec8273
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230329/51c6edc7/attachment-0001.html>