summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/GHC/Rename/Expr.hs10
-rw-r--r--compiler/GHC/Tc/Module.hs10
-rw-r--r--compiler/GHC/Tc/TyCl.hs24
-rw-r--r--compiler/GHC/Tc/TyCl/Instance.hs21
-rw-r--r--compiler/GHC/Tc/TyCl/Instance.hs-boot2
-rw-r--r--compiler/GHC/Tc/TyCl/Utils.hs9
-rw-r--r--compiler/GHC/Tc/Types.hs1
-rw-r--r--compiler/GHC/Tc/Utils/Env.hs22
8 files changed, 68 insertions, 31 deletions
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index fe8056f6c6..93949c5d83 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -232,9 +232,13 @@ rnExpr (HsVar _ (L l v))
| otherwise
-> finishHsVar (L (na2la l) name) ;
- Just (FieldGreName fl) ->
- let sel_name = flSelector fl in
- return ( HsRecSel noExtField (FieldOcc sel_name (L l v) ), unitFV sel_name) ;
+ Just (FieldGreName fl)
+ -> do { let sel_name = flSelector fl
+ ; this_mod <- getModule
+ ; when (nameIsLocalOrFrom this_mod sel_name) $
+ checkThLocalName sel_name
+ ; return ( HsRecSel noExtField (FieldOcc sel_name (L l v) ), unitFV sel_name)
+ }
}
}
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index bf190f059c..9b7bed6aac 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -704,7 +704,7 @@ tcRnHsBootDecls hsc_src decls
-- Typecheck type/class/instance decls
; traceTc "Tc2 (boot)" empty
- ; (tcg_env, inst_infos, _deriv_binds, _class_scoped_tv_env)
+ ; (tcg_env, inst_infos, _deriv_binds, _class_scoped_tv_env, _th_bndrs)
<- tcTyClsInstDecls tycl_decls deriv_decls val_binds
; setGblEnv tcg_env $ do {
@@ -1463,10 +1463,11 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
-- Source-language instances, including derivings,
-- and import the supporting declarations
traceTc "Tc3" empty ;
- (tcg_env, inst_infos, class_scoped_tv_env,
+ (tcg_env, inst_infos, class_scoped_tv_env, th_bndrs,
XValBindsLR (NValBinds deriv_binds deriv_sigs))
<- tcTyClsInstDecls tycl_decls deriv_decls val_binds ;
+ updLclEnv (\tcl_env -> tcl_env { tcl_th_bndrs = th_bndrs `plusNameEnv` tcl_th_bndrs tcl_env }) $
setGblEnv tcg_env $ do {
-- Generate Applicative/Monad proposal (AMP) warnings
@@ -1746,13 +1747,14 @@ tcTyClsInstDecls :: [TyClGroup GhcRn]
-- process; contains all dfuns for
-- this module
ClassScopedTVEnv, -- Class scoped type variables
+ ThBindEnv, -- TH binding levels
HsValBinds GhcRn) -- Supporting bindings for derived
-- instances
tcTyClsInstDecls tycl_decls deriv_decls binds
= tcAddDataFamConPlaceholders (tycl_decls >>= group_instds) $
tcAddPatSynPlaceholders (getPatSynBinds binds) $
- do { (tcg_env, inst_info, deriv_info, class_scoped_tv_env)
+ do { (tcg_env, inst_info, deriv_info, class_scoped_tv_env, th_bndrs)
<- tcTyAndClassDecls tycl_decls ;
; setGblEnv tcg_env $ do {
-- With the @TyClDecl@s and @InstDecl@s checked we're ready to
@@ -1767,7 +1769,7 @@ tcTyClsInstDecls tycl_decls deriv_decls binds
; setGblEnv tcg_env' $ do {
failIfErrsM
; pure ( tcg_env', inst_info' ++ inst_info
- , class_scoped_tv_env, val_binds )
+ , class_scoped_tv_env, th_bndrs, val_binds )
}}}
{- *********************************************************************
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
index c775acbb7d..08370c2a89 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/compiler/GHC/Tc/TyCl.hs
@@ -148,34 +148,37 @@ tcTyAndClassDecls :: [TyClGroup GhcRn] -- Mutually-recursive groups in
, [InstInfo GhcRn] -- Source-code instance decls info
, [DerivInfo] -- Deriving info
, ClassScopedTVEnv -- Class scoped type variables
+ , ThBindEnv -- TH binding levels
)
-- 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 [] [] emptyNameEnv tyclds_s
+ = checkNoErrs $ fold_env [] [] emptyNameEnv emptyNameEnv tyclds_s
where
fold_env :: [InstInfo GhcRn]
-> [DerivInfo]
-> ClassScopedTVEnv
+ -> ThBindEnv
-> [TyClGroup GhcRn]
- -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ClassScopedTVEnv)
- fold_env inst_info deriv_info class_scoped_tv_env []
+ -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ClassScopedTVEnv, ThBindEnv)
+ fold_env inst_info deriv_info class_scoped_tv_env th_bndrs []
= do { gbl_env <- getGblEnv
- ; return (gbl_env, inst_info, deriv_info, class_scoped_tv_env) }
- fold_env inst_info deriv_info class_scoped_tv_env (tyclds:tyclds_s)
- = do { (tcg_env, inst_info', deriv_info', class_scoped_tv_env')
+ ; return (gbl_env, inst_info, deriv_info, class_scoped_tv_env, th_bndrs) }
+ fold_env inst_info deriv_info class_scoped_tv_env th_bndrs (tyclds:tyclds_s)
+ = do { (tcg_env, inst_info', deriv_info', class_scoped_tv_env', th_bndrs')
<- tcTyClGroup tyclds
; setGblEnv tcg_env $
-- remaining groups are typechecked in the extended global env.
fold_env (inst_info' ++ inst_info)
(deriv_info' ++ deriv_info)
(class_scoped_tv_env' `plusNameEnv` class_scoped_tv_env)
+ (th_bndrs' `plusNameEnv` th_bndrs)
tyclds_s }
tcTyClGroup :: TyClGroup GhcRn
- -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ClassScopedTVEnv)
+ -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ClassScopedTVEnv, ThBindEnv)
-- 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
@@ -213,17 +216,18 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds
-- Step 3: Add the implicit things;
-- we want them in the environment because
-- they may be mentioned in interface files
- ; gbl_env <- addTyConsToGblEnv tyclss
+ ; (gbl_env, th_bndrs) <- addTyConsToGblEnv tyclss
-- Step 4: check instance declarations
- ; (gbl_env', inst_info, datafam_deriv_info) <-
+ ; (gbl_env', inst_info, datafam_deriv_info, th_bndrs') <-
setGblEnv gbl_env $
tcInstDecls1 instds
; let deriv_info = datafam_deriv_info ++ data_deriv_info
; let gbl_env'' = gbl_env'
{ tcg_ksigs = tcg_ksigs gbl_env' `unionNameSet` kindless }
- ; return (gbl_env'', inst_info, deriv_info, class_scoped_tv_env) }
+ ; return (gbl_env'', inst_info, deriv_info, class_scoped_tv_env,
+ th_bndrs' `plusNameEnv` th_bndrs) }
-- Gives the kind for every TyCon that has a standalone kind signature
type KindSigEnv = NameEnv Kind
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index 609ef55837..386c657aba 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -388,7 +388,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
+ ThBindEnv) -- TH binding levels
tcInstDecls1 inst_decls
= do { -- Do class and family instance declarations
@@ -398,13 +399,14 @@ tcInstDecls1 inst_decls
fam_insts = concat fam_insts_s
local_infos = concat local_infos_s
- ; gbl_env <- addClsInsts local_infos $
- addFamInsts fam_insts $
- getGblEnv
+ ; (gbl_env, th_bndrs) <-
+ addClsInsts local_infos $
+ addFamInsts fam_insts
; return ( gbl_env
, local_infos
- , concat datafam_deriv_infos ) }
+ , concat datafam_deriv_infos
+ , th_bndrs ) }
-- | Use DerivInfo for data family instances (produced by tcInstDecls1),
-- datatype declarations (TyClDecl), and standalone deriving declarations
@@ -425,17 +427,18 @@ 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 (TcGblEnv, ThBindEnv)
-- Extend (a) the family instance envt
-- (b) the type envt with stuff from data type decls
-addFamInsts fam_insts thing_inside
+addFamInsts fam_insts
= tcExtendLocalFamInstEnv fam_insts $
tcExtendGlobalEnv axioms $
do { traceTc "addFamInsts" (pprFamInsts fam_insts)
- ; gbl_env <- addTyConsToGblEnv data_rep_tycons
+ ; (gbl_env, th_bndrs) <- addTyConsToGblEnv data_rep_tycons
-- Does not add its axiom; that comes
-- from adding the 'axioms' above
- ; setGblEnv gbl_env thing_inside }
+ ; return (gbl_env, th_bndrs)
+ }
where
axioms = map (ACoAxiom . toBranchedAxiom . famInstAxiom) fam_insts
data_rep_tycons = famInstsRepTyCons fam_insts
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs-boot b/compiler/GHC/Tc/TyCl/Instance.hs-boot
index 1e47211460..0a14acbda3 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs-boot
+++ b/compiler/GHC/Tc/TyCl/Instance.hs-boot
@@ -13,4 +13,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], ThBindEnv)
diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs
index dcc57592a5..1cb3555f35 100644
--- a/compiler/GHC/Tc/TyCl/Utils.hs
+++ b/compiler/GHC/Tc/TyCl/Utils.hs
@@ -765,12 +765,14 @@ updateRoleEnv name n role
* *
********************************************************************* -}
-addTyConsToGblEnv :: [TyCon] -> TcM TcGblEnv
+addTyConsToGblEnv :: [TyCon] -> TcM (TcGblEnv, ThBindEnv)
-- Given a [TyCon], add to the TcGblEnv
-- * extend the TypeEnv with the tycons
-- * extend the TypeEnv with their implicitTyThings
-- * extend the TypeEnv with any default method Ids
-- * add bindings for record selectors
+-- Return separately the TH levels of these bindings,
+-- to be added to a LclEnv later.
addTyConsToGblEnv tyclss
= tcExtendTyConEnv tyclss $
tcExtendGlobalEnvImplicit implicit_things $
@@ -778,7 +780,10 @@ addTyConsToGblEnv tyclss
do { traceTc "tcAddTyCons" $ vcat
[ text "tycons" <+> ppr tyclss
, text "implicits" <+> ppr implicit_things ]
- ; tcRecSelBinds (mkRecSelBinds tyclss) }
+ ; gbl_env <- tcRecSelBinds (mkRecSelBinds tyclss)
+ ; th_bndrs <- tcTyThBinders implicit_things
+ ; return (gbl_env, th_bndrs)
+ }
where
implicit_things = concatMap implicitTyConThings tyclss
def_meth_ids = mkDefaultMethodIds tyclss
diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs
index f89949d1f8..39ff861153 100644
--- a/compiler/GHC/Tc/Types.hs
+++ b/compiler/GHC/Tc/Types.hs
@@ -59,6 +59,7 @@ module GHC.Tc.Types(
topStage, topAnnStage, topSpliceStage,
ThLevel, impLevel, outerLevel, thLevel,
ForeignSrcLang(..), THDocs, DocLoc(..),
+ ThBindEnv,
-- Arrows
ArrowCtxt(..),
diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs
index 65785fc822..ad74d919ab 100644
--- a/compiler/GHC/Tc/Utils/Env.hs
+++ b/compiler/GHC/Tc/Utils/Env.hs
@@ -18,7 +18,7 @@ module GHC.Tc.Utils.Env(
-- Global environment
tcExtendGlobalEnv, tcExtendTyConEnv,
tcExtendGlobalEnvImplicit, setGlobalTypeEnv,
- tcExtendGlobalValEnv,
+ tcExtendGlobalValEnv, tcTyThBinders,
tcLookupLocatedGlobal, tcLookupGlobal, tcLookupGlobalOnly,
tcLookupTyCon, tcLookupClass,
tcLookupDataCon, tcLookupPatSyn, tcLookupConLike,
@@ -95,7 +95,7 @@ import GHC.Tc.Types.Origin ( CtOrigin(UsageEnvironmentOf) )
import GHC.Core.UsageEnv
import GHC.Core.InstEnv
-import GHC.Core.DataCon ( DataCon )
+import GHC.Core.DataCon ( DataCon, flSelector )
import GHC.Core.PatSyn ( PatSyn )
import GHC.Core.ConLike
import GHC.Core.TyCon
@@ -402,6 +402,24 @@ tcExtendTyConEnv tycons thing_inside
tcExtendGlobalEnvImplicit (map ATyCon tycons) thing_inside
}
+-- Given a [TyThing] of "non-value" bindings coming from type decls
+-- (constructors, field selectors, class methods) return their
+-- TH binding levels (to be added to a LclEnv).
+-- See GHC ticket #17820 .
+tcTyThBinders :: [TyThing] -> TcM ThBindEnv
+tcTyThBinders implicit_things = do
+ stage <- getStage
+ let th_lvl = thLevel stage
+ th_bndrs = mkNameEnv
+ [ ( n , (TopLevel, th_lvl) ) | n <- names ]
+ return th_bndrs
+ where
+ names = concatMap get_names implicit_things
+ get_names (AConLike acl) =
+ conLikeName acl : map flSelector (conLikeFieldLabels acl)
+ get_names (AnId i) = [idName i]
+ get_names _ = []
+
tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
-- Same deal as tcExtendGlobalEnv, but for Ids
tcExtendGlobalValEnv ids thing_inside
View Lorry Controller Status