[Git][ghc/ghc][wip/amg/hasfield-2020] Remove abominable tcRemoveDataFamConPlaceholders
Adam Gundry
gitlab at gitlab.haskell.org
Fri Sep 18 22:13:31 UTC 2020
Adam Gundry pushed to branch wip/amg/hasfield-2020 at Glasgow Haskell Compiler / GHC
Commits:
684c39f9 by Adam Gundry at 2020-09-18T23:12:17+01:00
Remove abominable tcRemoveDataFamConPlaceholders
- - - - -
5 changed files:
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/TyCl/Instance.hs-boot
- compiler/GHC/Tc/TyCl/Utils.hs
Changes:
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -100,6 +100,7 @@ import GHC.Tc.Utils.TcMType
import GHC.Tc.Utils.TcType
import GHC.Tc.Solver
import GHC.Tc.TyCl
+import GHC.Tc.TyCl.Utils ( tcRecSelBinds )
import GHC.Tc.Instance.Typeable ( mkTypeableBinds )
import GHC.Tc.Utils.Backpack
import GHC.Iface.Load
@@ -653,10 +654,16 @@ tcRnHsBootDecls hsc_src decls
-- Typecheck type/class/instance decls
; traceTc "Tc2 (boot)" empty
- ; (tcg_env, inst_infos, _deriv_binds)
+ ; (tcg_env, inst_infos, _deriv_binds, rec_sel_upd_binds)
<- tcTyClsInstDecls tycl_decls deriv_decls val_binds
; setGblEnv tcg_env $ do {
+ -- Record selectors and updaters
+ -- See Note [Calling tcRecSelBinds] in GHC.Tc.TyCl.Utils
+ traceTc "Tc3a" empty ;
+ tcg_env <- tcRecSelBinds rec_sel_upd_binds ;
+ setGblEnv tcg_env $ do {
+
-- Emit Typeable bindings
; tcg_env <- mkTypeableBinds
; setGblEnv tcg_env $ do {
@@ -680,7 +687,7 @@ tcRnHsBootDecls hsc_src decls
}
; setGlobalTypeEnv gbl_env type_env2
- }}}
+ }}}}
; traceTc "boot" (ppr lie); return gbl_env }
badBootDecl :: HscSource -> String -> Located decl -> TcM ()
@@ -1412,11 +1419,18 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
-- Source-language instances, including derivings,
-- and import the supporting declarations
traceTc "Tc3" empty ;
- (tcg_env, inst_infos, XValBindsLR (NValBinds deriv_binds deriv_sigs))
+ (tcg_env, inst_infos, XValBindsLR (NValBinds deriv_binds deriv_sigs)
+ , rec_sel_upd_binds)
<- tcTyClsInstDecls tycl_decls deriv_decls val_binds ;
setGblEnv tcg_env $ do {
+ -- Record selectors and updaters
+ -- See Note [Calling tcRecSelBinds] in GHC.Tc.TyCl.Utils
+ traceTc "Tc3a" empty ;
+ tcg_env <- tcRecSelBinds rec_sel_upd_binds ;
+ setGblEnv tcg_env $ do {
+
-- Generate Applicative/Monad proposal (AMP) warnings
traceTc "Tc3b" empty ;
@@ -1493,7 +1507,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
addUsedGREs (bagToList fo_gres) ;
return (tcg_env', tcl_env)
- }}}}}}
+ }}}}}}}
tcTopSrcDecls _ = panic "tcTopSrcDecls: ValBindsIn"
@@ -1689,13 +1703,14 @@ tcTyClsInstDecls :: [TyClGroup GhcRn]
[InstInfo GhcRn], -- Source-code instance decls to
-- process; contains all dfuns for
-- this module
- HsValBinds GhcRn) -- Supporting bindings for derived
+ HsValBinds GhcRn, -- Supporting bindings for derived
-- instances
+ [(Id, LHsBind GhcRn)]) -- Record selector/updater bindings
tcTyClsInstDecls tycl_decls deriv_decls binds
= tcAddDataFamConPlaceholders (tycl_decls >>= group_instds) $
tcAddPatSynPlaceholders (getPatSynBinds binds) $
- do { (tcg_env, inst_info, deriv_info)
+ do { (tcg_env, inst_info, deriv_info, rec_sel_upd_binds)
<- tcTyAndClassDecls tycl_decls ;
; setGblEnv tcg_env $ do {
-- With the @TyClDecl at s and @InstDecl at s checked we're ready to
@@ -1709,7 +1724,7 @@ tcTyClsInstDecls tycl_decls deriv_decls binds
<- tcInstDeclsDeriv deriv_info deriv_decls
; setGblEnv tcg_env' $ do {
failIfErrsM
- ; pure (tcg_env', inst_info' ++ inst_info, val_binds)
+ ; pure (tcg_env', inst_info' ++ inst_info, val_binds, rec_sel_upd_binds)
}}}
{- *********************************************************************
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -130,31 +130,34 @@ tcTyAndClassDecls :: [TyClGroup GhcRn] -- Mutually-recursive groups in
-- and their implicit Ids,DataCons
, [InstInfo GhcRn] -- Source-code instance decls info
, [DerivInfo] -- Deriving info
+ , [(Id, LHsBind GhcRn)] -- Record selector/updater bindings
)
-- Fails if there are any errors
tcTyAndClassDecls tyclds_s
-- The code recovers internally, but if anything gave rise to
-- an error we'd better stop now, to avoid a cascade
-- Type check each group in dependency order folding the global env
- = checkNoErrs $ fold_env [] [] tyclds_s
+ = checkNoErrs $ fold_env [] [] [] tyclds_s
where
fold_env :: [InstInfo GhcRn]
-> [DerivInfo]
+ -> [(Id, LHsBind GhcRn)]
-> [TyClGroup GhcRn]
- -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
- fold_env inst_info deriv_info []
+ -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], [(Id, LHsBind GhcRn)])
+ fold_env inst_info deriv_info rec_sel_upd_binds []
= do { gbl_env <- getGblEnv
- ; return (gbl_env, inst_info, deriv_info) }
- fold_env inst_info deriv_info (tyclds:tyclds_s)
- = do { (tcg_env, inst_info', deriv_info') <- tcTyClGroup tyclds
+ ; return (gbl_env, inst_info, deriv_info, rec_sel_upd_binds) }
+ fold_env inst_info deriv_info rec_sel_upd_binds (tyclds:tyclds_s)
+ = do { (tcg_env, inst_info', deriv_info', rec_sel_upd_binds') <- tcTyClGroup tyclds
; setGblEnv tcg_env $
-- remaining groups are typechecked in the extended global env.
fold_env (inst_info' ++ inst_info)
(deriv_info' ++ deriv_info)
+ (rec_sel_upd_binds' ++ rec_sel_upd_binds)
tyclds_s }
tcTyClGroup :: TyClGroup GhcRn
- -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
+ -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], [(Id, LHsBind GhcRn)])
-- Typecheck one strongly-connected component of type, class, and instance decls
-- See Note [TyClGroups and dependency analysis] in GHC.Hs.Decls
tcTyClGroup (TyClGroup { group_tyclds = tyclds
@@ -195,12 +198,16 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds
; gbl_env <- addTyConsToGblEnv tyclss
-- Step 4: check instance declarations
- ; (gbl_env', inst_info, datafam_deriv_info) <-
+ ; (gbl_env', inst_info, datafam_deriv_info, data_rep_tycons) <-
setGblEnv gbl_env $
tcInstDecls1 instds
+ -- Step 5: build record selectors/updaters, don't type-check them yet
+ -- See Note [Calling tcRecSelBinds] in GHC.Tc.TyCl.Utils
+ ; rec_sel_upd_binds <- mkRecSelBinds (tyclss ++ data_rep_tycons)
+
; let deriv_info = datafam_deriv_info ++ data_deriv_info
- ; return (gbl_env', inst_info, deriv_info) }
+ ; return (gbl_env', inst_info, deriv_info, rec_sel_upd_binds) }
-- Gives the kind for every TyCon that has a standalone kind signature
type KindSigEnv = NameEnv Kind
=====================================
compiler/GHC/Tc/TyCl/Instance.hs
=====================================
@@ -382,7 +382,8 @@ tcInstDecls1 -- Deal with both source-code and imported instance decls
-> TcM (TcGblEnv, -- The full inst env
[InstInfo GhcRn], -- Source-code instance decls to process;
-- contains all dfuns for this module
- [DerivInfo]) -- From data family instances
+ [DerivInfo], -- From data family instances
+ [TyCon]) -- Data family instance representation tycons
tcInstDecls1 inst_decls
= do { -- Do class and family instance declarations
@@ -392,13 +393,14 @@ tcInstDecls1 inst_decls
fam_insts = concat fam_insts_s
local_infos = concat local_infos_s
- ; gbl_env <- addClsInsts local_infos $
+ ; (data_rep_tycons, gbl_env) <- addClsInsts local_infos $
addFamInsts fam_insts $
getGblEnv
; return ( gbl_env
, local_infos
- , concat datafam_deriv_infos ) }
+ , concat datafam_deriv_infos
+ , data_rep_tycons ) }
-- | Use DerivInfo for data family instances (produced by tcInstDecls1),
-- datatype declarations (TyClDecl), and standalone deriving declarations
@@ -419,9 +421,10 @@ addClsInsts :: [InstInfo GhcRn] -> TcM a -> TcM a
addClsInsts infos thing_inside
= tcExtendLocalInstEnv (map iSpec infos) thing_inside
-addFamInsts :: [FamInst] -> TcM a -> TcM a
+addFamInsts :: [FamInst] -> TcM a -> TcM ([TyCon], a)
-- Extend (a) the family instance envt
-- (b) the type envt with stuff from data type decls
+-- Additionally return the data family representation tycons
addFamInsts fam_insts thing_inside
= tcExtendLocalFamInstEnv fam_insts $
tcExtendGlobalEnv axioms $
@@ -429,7 +432,8 @@ addFamInsts fam_insts thing_inside
; gbl_env <- addTyConsToGblEnv data_rep_tycons
-- Does not add its axiom; that comes
-- from adding the 'axioms' above
- ; setGblEnv gbl_env thing_inside }
+ ; x <- setGblEnv gbl_env thing_inside
+ ; return (data_rep_tycons, x) }
where
axioms = map (ACoAxiom . toBranchedAxiom . famInstAxiom) fam_insts
data_rep_tycons = famInstsRepTyCons fam_insts
=====================================
compiler/GHC/Tc/TyCl/Instance.hs-boot
=====================================
@@ -5,6 +5,7 @@
module GHC.Tc.TyCl.Instance ( tcInstDecls1 ) where
+import GHC.Core.TyCon
import GHC.Hs
import GHC.Tc.Types
import GHC.Tc.Utils.Env( InstInfo )
@@ -13,4 +14,4 @@ import GHC.Tc.Deriv
-- We need this because of the mutual recursion
-- between GHC.Tc.TyCl and GHC.Tc.TyCl.Instance
tcInstDecls1 :: [LInstDecl GhcRn]
- -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
+ -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], [TyCon])
=====================================
compiler/GHC/Tc/TyCl/Utils.hs
=====================================
@@ -763,9 +763,7 @@ addTyConsToGblEnv tyclss
do { traceTc "tcAddTyCons" $ vcat
[ text "tycons" <+> ppr tyclss
, text "implicits" <+> ppr implicit_things ]
- ; gbl_env <- tcRemoveDataFamConPlaceholders tyclss $
- tcRecSelBinds =<< mkRecSelBinds tyclss
- ; return gbl_env }
+ ; getGblEnv }
where
implicit_things = concatMap implicitTyConThings tyclss
def_meth_ids = mkDefaultMethodIds tyclss
@@ -1390,30 +1388,15 @@ exists, we do not currently solve HasField constraints for fields defined by
pattern synonyms. And since we do not need updaters for anything other than
solving HasField constraints, we do not generate them for pattern synonyms.
--}
-
-
-tcRemoveDataFamConPlaceholders :: [TyCon] -> TcM a -> TcM a
--- ^ Remove the placeholders added by tcAddDataFamConPlaceholders
--- See Note [tcRemoveDataFamConPlaceholders]
-tcRemoveDataFamConPlaceholders tycons = updLclEnv upd_env
- where
- upd_env env = env { tcl_env = delListFromNameEnv (tcl_env env) cons }
-
- cons = [ dataConName data_con
- | tycon <- tycons
- , isFamInstTyCon tycon
- , data_con <- tyConDataCons tycon
- ]
-{-
-Note [tcRemoveDataFamConPlaceholders]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Calling tcRecSelBinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When type-checking record update bindings, we need to be able to look up the
data constructors for the corresponding datatypes, because the constructors are
used in the definitions. However, for data constructors in data family
-instances the tcl_env contains placeholder bindings added to prevent the use of
-promotion (see Note [AFamDataCon: not promoting data family constructors] in
-GHC.Tc.Utils.Env). Thus we must remove them again before the call to
-tcRecSelBinds in addTyConsToGblEnv.
+instances, tcTyClsInstDecls adds placeholder bindings added to prevent the use
+of promotion (see Note [AFamDataCon: not promoting data family constructors] in
+GHC.Tc.Utils.Env). Thus we cannot call tcReclSelBinds in addTyConsToGblEnv, but
+instead have to wait until tcTyClsInstDecls has completed.
+
-}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/684c39f92e7b382de8ac9906ac16a152bb5f1f0e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/684c39f92e7b382de8ac9906ac16a152bb5f1f0e
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/20200918/a27a9f7a/attachment-0001.html>
More information about the ghc-commits
mailing list