[Git][ghc/ghc][wip/T25266] Fix build
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Mon Oct 14 22:28:58 UTC 2024
Simon Peyton Jones pushed to branch wip/T25266 at Glasgow Haskell Compiler / GHC
Commits:
6045cee9 by Simon Peyton Jones at 2024-10-14T23:28:43+01:00
Fix build
- - - - -
2 changed files:
- compiler/GHC/Tc/Solver.hs
- testsuite/tests/typecheck/should_compile/T13785.hs
Changes:
=====================================
compiler/GHC/Tc/Solver.hs
=====================================
@@ -1469,55 +1469,19 @@ decideAndPromoteTyVars infer_mode name_taus psigs wanted
++ tau_tys ++ post_mr_quant)
co_var_tvs = closeOverKinds co_vars
- -- outer_tvs are belong to some outer level,
+ -- outer_tvs belong to some outer level,
-- so we definitely can't quantify over them
outer_tvs = outerLevelTyVars tc_lvl $
tyCoVarsOfTypes can_quant `unionVarSet` tyCoVarsOfTypes no_quant
- mono_tvs_ignoring_mr
+ mono_tvs_without_mr
| isTopTcLevel tc_lvl = outer_tvs
| otherwise = outer_tvs
`unionVarSet` tyCoVarsOfTypes no_quant
`unionVarSet` co_var_tvs
- mono_tvs_accounting_for_mr
- = mono_tvs_ignoring_mr `unionVarSet` tyCoVarsOfTypes mr_no_quant
-
-{-
- -- mono_tvs0 are all the type variables we can't quantify over
- mono_tvs0
- | isTopTcLevel tc_lvl
- -- At top level: we want to promote only tyvars that are
- -- (a) free in envt (outer_tvs)
- -- (b) will be defaulted (mr_no_quant)
- -- (c) determined by (a) or (b)
- -- mono_tvs0 deals with (a) or (b); closeWrtFunDeps deals with (c)
- = outer_tvs
- `unionVarSet` tyCoVarsOfTypes mr_no_quant
-
- | otherwise
- = outer_tvs
- `unionVarSet` tyCoVarsOfTypes mr_no_quant
- `unionVarSet` tyCoVarsOfTypes no_quant
- `unionVarSet` co_var_tvs
- -- If we don't quantify over a constraint in no_quant, we
- -- can either not-quantify its free vars (hoping that call
- -- sites will fix them) or just ignore it for the purposes
- -- of mono_tvs0 (leaving behind a perhaps insoluble residual
- -- constraint)
--}
-
- add_determined tvs = closeWrtFunDeps post_mr_quant tvs
- `delVarSetList` psig_qtvs
- -- Finally, delete psig_qtvs
- -- If the user has explicitly asked for quantification, then that
- -- request "wins" over the MR.
- --
- -- What if a psig variable is also free in the environment
- -- (i.e. says "no" to isQuantifiableTv)? That's OK: explanation
- -- in Step 2 of Note [Deciding quantification].
-
-
+ mono_tvs_with_mr
+ = mono_tvs_without_mr `unionVarSet` tyCoVarsOfTypes mr_no_quant
-- Next, use closeWrtFunDeps to find any other variables that are
-- determined by mono_tvs0, by functional dependencies or equalities.
@@ -1531,8 +1495,17 @@ decideAndPromoteTyVars infer_mode name_taus psigs wanted
-- are in the equality constraint with alpha. Actual test case:
-- typecheck/should_compile/tc213
-- see Note [growThetaTyVars vs closeWrtFunDeps]
- mono_tvs_with_mr = add_determined mono_tvs_accounting_for_mr
- mono_tvs_without_mr = add_determined mono_tvs_ignoring_mr
+ add_determined tvs = closeWrtFunDeps post_mr_quant tvs
+ `delVarSetList` psig_qtvs
+ -- Why delVarSetList psig_qtvs?
+ -- If the user has explicitly asked for quantification, then that
+ -- request "wins" over the MR.
+ --
+ -- What if a psig variable is also free in the environment
+ -- (i.e. says "no" to isQuantifiableTv)? That's OK: explanation
+ -- in Step 2 of Note [Deciding quantification].
+ mono_tvs_with_mr_det = add_determined mono_tvs_with_mr
+ mono_tvs_without_mr_det = add_determined mono_tvs_without_mr
-- Do not quantify over any constraint mentioning a "newly-mono" tyvar
-- The "newly-mono" tyvars are the ones not free in the envt, nor
@@ -1543,21 +1516,21 @@ decideAndPromoteTyVars infer_mode name_taus psigs wanted
-- but we do not want to generate f :: (C Int beta[0]) => beta[0] -> Int
-- Rather, we generate f :: beta[0] -> Int, but leave [W] C Int beta[0]
-- in the residual constraints, which will probably cause a type errors
- newly_mono = mono_tvs `minusVarSet` mono_tvs0
+ newly_mono_tvs = mono_tvs_with_mr_det `minusVarSet` mono_tvs_with_mr
final_quant
- | isTopTcLevel tc_lvl = filterOut (predMentions newly_mono) post_mr_quant
+ | isTopTcLevel tc_lvl = filterOut (predMentions newly_mono_tvs) post_mr_quant
| otherwise = post_mr_quant
-- Check if the Monomorphism Restriction has bitten
; warn_mr <- woptM Opt_WarnMonomorphism
; when (warn_mr && case infer_mode of { ApplyMR -> True; _ -> False}) $
- diagnosticTc (not (mono_tvs `subVarSet` mono_tvs_wo_mr)) $
+ diagnosticTc (not (mono_tvs_with_mr_det `subVarSet` mono_tvs_without_mr_det)) $
TcRnMonomorphicBindings (map fst name_taus)
-- If there is a variable in mono_tvs, but not in mono_tvs_wo_mr
-- then the MR has "bitten" and reduced polymorphism.
-- Promote the mono_tvs: see Note [Promote monomorphic tyvars]
- ; _ <- promoteTyVarSet mono_tvs
+ ; _ <- promoteTyVarSet mono_tvs_with_mr_det
; traceTc "decideAndPromoteTyVars" $ vcat
[ text "tc_lvl =" <+> ppr tc_lvl
@@ -1565,13 +1538,17 @@ decideAndPromoteTyVars infer_mode name_taus psigs wanted
, text "infer_mode =" <+> ppr infer_mode
, text "psigs =" <+> ppr psigs
, text "psig_qtvs =" <+> ppr psig_qtvs
- , text "mono_tvs0 =" <+> ppr mono_tvs0
+ , text "outer_tvs =" <+> ppr outer_tvs
+ , text "mono_tvs_with_mr =" <+> ppr mono_tvs_with_mr
+ , text "mono_tvs_without_mr =" <+> ppr mono_tvs_without_mr
+ , text "mono_tvs_with_mr_det =" <+> ppr mono_tvs_with_mr_det
+ , text "mono_tvs_without_mr_det =" <+> ppr mono_tvs_without_mr_det
+ , text "newly_mono_tvs =" <+> ppr newly_mono_tvs
, text "can_quant =" <+> ppr can_quant
, text "post_mr_quant =" <+> ppr post_mr_quant
, text "no_quant =" <+> ppr no_quant
, text "mr_no_quant =" <+> ppr mr_no_quant
, text "final_quant =" <+> ppr final_quant
- , text "mono_tvs =" <+> ppr mono_tvs
, text "co_vars =" <+> ppr co_vars ]
; return (final_quant, co_vars) }
=====================================
testsuite/tests/typecheck/should_compile/T13785.hs
=====================================
@@ -10,10 +10,10 @@ foo = bar >> baz >> bar1 >> bar2
where
-- Should not get MR warning
bar, baz :: m Char
- (bar, baz) = (c :: m Char, m Char)
+ (bar, baz) = c
-- Should not get MR warning
- (bar1, baz1) = (c :: (m Char, m Char))
+ (bar1, baz1) = c :: (m Char, m Char)
-- Should get MR warning
-- Natural type for the "whole binding": forall x. C x => (x Char, x Char)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6045cee9c5bc0b146503a6dde1ad480bb2a50c49
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6045cee9c5bc0b146503a6dde1ad480bb2a50c49
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/20241014/c4c483d5/attachment-0001.html>
More information about the ghc-commits
mailing list