TH stage restriction check for constructors, selectors, and class methods

Closes ticket #17820.

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