[Git][ghc/ghc][wip/int-index/term-capture] Push down term promotion error context extension
Vladislav Zavialov (@int-index)
gitlab at gitlab.haskell.org
Wed Aug 2 12:07:28 UTC 2023
Vladislav Zavialov pushed to branch wip/int-index/term-capture at Glasgow Haskell Compiler / GHC
Commits:
ac53f9a6 by Vladislav Zavialov at 2023-08-02T13:46:46+02:00
Push down term promotion error context extension
- - - - -
3 changed files:
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/TyCl/Utils.hs
Changes:
=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -189,13 +189,14 @@ Then we get
fm
-}
-tcTopBinds :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn]
+tcTopBinds :: (forall a. TcM a -> TcM a)
+ -> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn]
-> TcM (TcGblEnv, TcLclEnv)
-- The TcGblEnv contains the new tcg_binds and tcg_spects
-- The TcLclEnv has an extended type envt for the new bindings
-tcTopBinds binds sigs
+tcTopBinds no_terms binds sigs
= do { -- Pattern synonym bindings populate the global environment
- (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs getEnvs
+ (binds', (tcg_env, tcl_env)) <- tcValBinds no_terms TopLevel binds sigs getEnvs
; specs <- tcImpPrags sigs -- SPECIALISE prags for imported Ids
; complete_matches <- restoreEnvs (tcg_env, tcl_env) $ tcCompleteSigs sigs
@@ -258,7 +259,7 @@ tcLocalBinds (EmptyLocalBinds x) thing_inside
; return (EmptyLocalBinds x, thing) }
tcLocalBinds (HsValBinds x (XValBindsLR (NValBinds binds sigs))) thing_inside
- = do { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside
+ = do { (binds', thing) <- tcValBinds id NotTopLevel binds sigs thing_inside
; return (HsValBinds x (XValBindsLR (NValBinds binds' sigs)), thing) }
tcLocalBinds (HsValBinds _ (ValBinds {})) _ = panic "tcLocalBinds"
@@ -297,17 +298,19 @@ tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside
toDict ipClass x ty = mkHsWrap $ mkWpCastR $
wrapIP $ mkClassPred ipClass [x,ty]
-tcValBinds :: TopLevelFlag
+tcValBinds :: (forall a. TcM a -> TcM a)
+ -> TopLevelFlag
-> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], thing)
-tcValBinds top_lvl binds sigs thing_inside
+tcValBinds no_terms top_lvl binds sigs thing_inside
= do { -- Typecheck the signatures
-- It's easier to do so now, once for all the SCCs together
-- because a single signature f,g :: <type>
-- might relate to more than one SCC
- (poly_ids, sig_fn) <- tcAddPatSynPlaceholders patsyns $
+ (poly_ids, sig_fn) <- no_terms $
+ tcAddPatSynPlaceholders patsyns $
tcTySigs sigs
-- Extend the envt right away with all the Ids
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -1619,21 +1619,22 @@ tcTopSrcDecls (HsGroup { hs_ext = all_bndrs,
traceTc "Tc2 (src)" empty ;
-- See Note [Demotion of unqualified variables] in GHC.Rename.Env
- tcExtendKindEnv (mkTermVarPromErrEnv all_bndrs) $ do {
+ let { no_terms :: TcM a -> TcM a
+ ; no_terms = tcExtendKindEnv (mkTermVarPromErrEnv all_bndrs) } ;
-- Source-language instances, including derivings,
-- and import the supporting declarations
traceTc "Tc3" empty ;
(tcg_env, inst_infos, th_bndrs,
XValBindsLR (NValBinds deriv_binds deriv_sigs))
- <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ;
+ <- no_terms $ tcTyClsInstDecls tycl_decls deriv_decls val_binds ;
updLclCtxt (\tcl_env -> tcl_env { tcl_th_bndrs = th_bndrs `plusNameEnv` tcl_th_bndrs tcl_env }) $
setGblEnv tcg_env $ do {
-- Foreign import declarations next.
traceTc "Tc4" empty ;
- (fi_ids, fi_decls, fi_gres) <- tcForeignImports foreign_decls ;
+ (fi_ids, fi_decls, fi_gres) <- no_terms $ tcForeignImports foreign_decls ;
tcExtendGlobalValEnv fi_ids $ do {
-- Default declarations
@@ -1647,14 +1648,14 @@ tcTopSrcDecls (HsGroup { hs_ext = all_bndrs,
-- may be defined in terms of the former. (For instance,
-- the bindings produced in a Data instance.)
traceTc "Tc5" empty ;
- tc_envs <- tcTopBinds val_binds val_sigs;
+ tc_envs <- tcTopBinds no_terms val_binds val_sigs;
restoreEnvs tc_envs $ do {
-- Now GHC-generated derived bindings, generics, and selectors
-- Do not generate warnings from compiler-generated code;
-- hence the use of discardWarnings
tc_envs@(tcg_env, tcl_env)
- <- discardWarnings (tcTopBinds deriv_binds deriv_sigs) ;
+ <- discardWarnings (tcTopBinds no_terms deriv_binds deriv_sigs) ;
restoreEnvs tc_envs $ do { -- Environment doesn't change now
-- Second pass over class and instance declarations,
@@ -1700,7 +1701,7 @@ tcTopSrcDecls (HsGroup { hs_ext = all_bndrs,
addUsedGREs NoDeprecationWarnings (bagToList fo_gres) ;
return (tcg_env', tcl_env)
- }}}}}}}
+ }}}}}}
tcTopSrcDecls _ = panic "tcTopSrcDecls: ValBindsIn"
=====================================
compiler/GHC/Tc/TyCl/Utils.hs
=====================================
@@ -849,7 +849,7 @@ tcRecSelBinds sel_bind_prs
do { (rec_sel_binds, tcg_env) <- discardWarnings $
-- See Note [Impredicative record selectors]
setXOptM LangExt.ImpredicativeTypes $
- tcValBinds TopLevel binds sigs getGblEnv
+ tcValBinds id TopLevel binds sigs getGblEnv
; return (tcg_env `addTypecheckedBinds` map snd rec_sel_binds) }
where
sigs = [ L (noAnnSrcSpan loc) (XSig $ IdSig sel_id)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ac53f9a6d0df5d13d41c7c311488a48862397a42
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ac53f9a6d0df5d13d41c7c311488a48862397a42
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/20230802/5965e8f2/attachment-0001.html>
More information about the ghc-commits
mailing list