Magnus pushed to branch wip/mangoiv/26616 at Glasgow Haskell Compiler / GHC Commits: 768de01f by mangoiv at 2026-06-16T11:58:01+02:00 compiler: refactor error reporting code for ExplicitLevelImports Refactors error reporting code for ExplicitLevelImports to pass in a RdrName and a GlobalReaderElt to be able to report errors that are faithful to the source and to more precisely distinguish between names that are in scope from different qualifications. Fixes #27385 and #26616 - - - - - 30 changed files: - + changelog.d/26616 - compiler/GHC/Hs/Expr.hs - compiler/GHC/Rename/Env.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Rename/Splice.hs - compiler/GHC/Rename/Splice.hs-boot - compiler/GHC/Rename/Unbound.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Types/Name/Reader.hs - testsuite/tests/quotes/LiftErrMsg.stderr - testsuite/tests/quotes/LiftErrMsgDefer.stderr - testsuite/tests/quotes/LiftErrMsgTyped.stderr - testsuite/tests/splice-imports/SI03.stderr - testsuite/tests/splice-imports/SI05.stderr - testsuite/tests/splice-imports/SI25.stderr - testsuite/tests/splice-imports/SI28.stderr - testsuite/tests/splice-imports/SI31.stderr - testsuite/tests/splice-imports/T26088.stderr - testsuite/tests/splice-imports/T26090.stderr - + testsuite/tests/splice-imports/T26616.hs - + testsuite/tests/splice-imports/T26616.stderr - testsuite/tests/splice-imports/all.T Changes: ===================================== changelog.d/26616 ===================================== @@ -0,0 +1,9 @@ +section: compiler +synopsis: Fix bugs with ExplcitLevelImports accepting incorrect qualified imports and reporting errors + incorrectly in the presence of qualified imports +description: When reporting errors, ExplcitLevelImports would sometimes report identifiers qualified at a + module they were not oringally actually be qualified at. It would also allow using *any* qualified import + to bring an identifier into scope, even if that qualified import was not imported at the correct level. + This MR fixes both issues by passing more information to the responsible error reporting code. +mrs: !16195 +issues: #26616 #27385 ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -2254,6 +2254,7 @@ data HsImplicitLiftSplice = { implicit_lift_bind_lvl :: S.Set ThLevelIndex , implicit_lift_used_lvl :: ThLevelIndex , implicit_lift_gre :: Maybe GlobalRdrElt + -- ^ Nothing iff 'LevelCheckReason' is 'LevelCheckInstance' , implicit_lift_lid :: LIdOccP GhcRn } ===================================== compiler/GHC/Rename/Env.hs ===================================== @@ -12,9 +12,9 @@ module GHC.Rename.Env ( lookupLocatedTopBndrRnN, lookupTopBndrRn, - lookupLocatedOccRn, lookupLocatedOccRnConstr, lookupLocatedOccRnRecField, + lookupLocatedOccRn, lookupLocatedOccRnGRE, lookupLocatedOccRnConstr, lookupLocatedOccRnRecField, lookupLocatedOccRnNone, - lookupOccRn, lookupOccRn_maybe, lookupSameOccRn_maybe, + lookupOccRn, lookupOccRnGRE, lookupOccRn_maybe, lookupSameOccRn_maybe, lookupLocalOccRn_maybe, lookupInfoOccRn, lookupLocalOccThLvl_maybe, lookupLocalOccRn, lookupTypeOccRn, @@ -992,6 +992,11 @@ lookupLocatedOccRn :: WhatLooking -> TcRn (GenLocated (EpAnn ann) Name) lookupLocatedOccRn what = wrapLocMA (lookupOccRn what) +lookupLocatedOccRnGRE :: WhatLooking + -> GenLocated (EpAnn ann) RdrName + -> TcRn (GenLocated (EpAnn ann) GlobalRdrElt) +lookupLocatedOccRnGRE what = wrapLocMA (lookupOccRnGRE what) + lookupLocatedOccRnConstr :: GenLocated (EpAnn ann) RdrName -> TcRn (GenLocated (EpAnn ann) Name) lookupLocatedOccRnConstr = wrapLocMA lookupOccRnConstr @@ -1019,11 +1024,14 @@ lookupLocalOccThLvl_maybe name -- | lookupOccRn looks up an occurrence of a RdrName, and uses its argument to -- determine what kind of suggestions should be displayed if it is not in scope lookupOccRn :: WhatLooking -> RdrName -> RnM Name -lookupOccRn which_suggest rdr_name +lookupOccRn which_suggest = fmap greName . lookupOccRnGRE which_suggest + +lookupOccRnGRE :: WhatLooking -> RdrName -> RnM GlobalRdrElt +lookupOccRnGRE which_suggest rdr_name = do { mb_gre <- lookupOccRn_maybe rdr_name ; case mb_gre of - Just gre -> return $ greName gre - Nothing -> reportUnboundName which_suggest rdr_name } + Just gre -> return gre + Nothing -> mkUnboundGRERdr rdr_name <$ reportUnboundName which_suggest rdr_name } -- | Look up an occurrence of a 'RdrName'. -- @@ -1087,16 +1095,22 @@ lookupLocalOccRn rdr_name -- lookupTypeOccRn looks up an optionally promoted RdrName. -- Used for looking up type variables. -lookupTypeOccRn :: RdrName -> RnM Name +lookupTypeOccRn :: RdrName -> RnM GlobalRdrElt -- see Note [Demotion] lookupTypeOccRn rdr_name = do { mb_gre <- lookupOccRn_maybe rdr_name ; case mb_gre of - Just gre -> return $ greName gre - Nothing -> - if occName rdr_name == occName eqTyCon_RDR -- See Note [eqTyCon (~) compatibility fallback] - then eqTyConName <$ addDiagnostic TcRnTypeEqualityOutOfScope - else lookup_demoted rdr_name } + Just gre -> return gre + Nothing + | occName rdr_name == occName eqTyCon_RDR -- See Note [eqTyCon (~) compatibility fallback] + -> mkExactGRE + eqTyConName + -- eqTyCon is not an open family ty con (which is the only + -- case in which the functoriality of TyConFlavour actually + -- matters) + (IAmTyCon (eqTyConName <$ tyConFlavour eqTyCon)) + <$ addDiagnostic TcRnTypeEqualityOutOfScope + | otherwise -> lookup_demoted rdr_name } {- Note [eqTyCon (~) compatibility fallback] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1113,7 +1127,7 @@ but emit appropriate warnings. -} -- Used when looking up a term name (varName or dataName) in a type -lookup_demoted :: RdrName -> RnM Name +lookup_demoted :: RdrName -> RnM GlobalRdrElt lookup_demoted rdr_name | Just demoted_rdr <- demoteRdrNameTcCls rdr_name -- Maybe it's the name of a *data* constructor @@ -1121,11 +1135,12 @@ lookup_demoted rdr_name ; star_is_type <- xoptM LangExt.StarIsType ; let is_star_type = if star_is_type then StarIsType else StarIsNotType star_is_type_hints = noStarIsTypeHints is_star_type rdr_name + mk_unbound_name_GRE hint = unboundGREX looking_for rdr_name hint ; if data_kinds then do { mb_demoted_gre <- lookupOccRn_maybe demoted_rdr ; case mb_demoted_gre of - Nothing -> unboundNameX looking_for rdr_name star_is_type_hints - Just demoted_gre -> return $ greName demoted_gre} + Nothing -> mk_unbound_name_GRE star_is_type_hints + Just demoted_gre -> return demoted_gre} else do { -- We need to check if a data constructor of this name is -- in scope to give good error messages. However, we do -- not want to give an additional error if the data @@ -1137,13 +1152,13 @@ lookup_demoted rdr_name = [SuggestExtension $ SuggestSingleExtension additional LangExt.DataKinds] | otherwise = star_is_type_hints - ; unboundNameX looking_for rdr_name suggestion } } + ; mk_unbound_name_GRE suggestion } } | isQual rdr_name, Just demoted_rdr_name <- demoteRdrNameTv rdr_name -- Definitely an illegal term variable, as type variables are never exported. -- See Note [Demotion of unqualified variables] (W2) - = report_qualified_term_in_types rdr_name demoted_rdr_name + = mkUnboundGREName <$> report_qualified_term_in_types rdr_name demoted_rdr_name | isUnqual rdr_name, Just demoted_rdr_name <- demoteRdrNameTv rdr_name @@ -1152,12 +1167,12 @@ lookup_demoted rdr_name ; if required_type_arguments then do { mb_demoted_gre <- lookupOccRn_maybe demoted_rdr_name ; case mb_demoted_gre of - Nothing -> unboundName (LF WL_Anything WL_Anywhere) rdr_name - Just demoted_gre -> return $ greName demoted_gre } - else unboundName looking_for rdr_name } + Nothing -> unboundGRE (LF WL_Anything WL_Anywhere) rdr_name + Just demoted_gre -> return demoted_gre } + else unboundGRE looking_for rdr_name } | otherwise - = unboundName looking_for rdr_name + = unboundGRE looking_for rdr_name where looking_for = LF WL_Type WL_Anywhere ===================================== compiler/GHC/Rename/Expr.hs ===================================== @@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} @@ -321,7 +320,7 @@ rnExpr (HsVar _ (L l v)) -- matching GRE and add a name clash error -- (see lookupGlobalOccRn_overloaded, called by lookupExprOccRn). -> do { let sel_name = flSelector $ recFieldLabel fld_info - ; checkThLocalNameNoLift (L (l2l l) (WithUserRdr v sel_name)) + ; checkThLocalNameNoLift (L l $ WithUserRdr v gre) ; return (XExpr (HsRecSelRn (FieldOcc v (L l sel_name))), unitFN sel_name) } | nm == nilDataConName @@ -332,7 +331,7 @@ rnExpr (HsVar _ (L l v)) -> rnExpr (ExplicitList noAnn []) | otherwise - -> do { res_expr <- checkThLocalNameWithLift (L (l2l l) (WithUserRdr v nm)) + -> do { res_expr <- checkThLocalNameWithLift (L (l2l l) (WithUserRdr v gre)) ; return (res_expr, unitFN nm) } }}} ===================================== compiler/GHC/Rename/HsType.hs ===================================== @@ -606,20 +606,21 @@ rnHsTyKi env tv@(HsTyVar _ ip (L loc rdr_name)) TcRnUnexpectedKindVar rdr_name -- Any type variable at the kind level is illegal without the use -- of PolyKinds (see #14710) - ; name <- rnTyVar env rdr_name + ; gre <- rnTyVar env rdr_name ; this_mod <- getModule ; explicit_level_imports <- xoptM LangExt.ExplicitLevelImports - ; let loc_name_with_rdr = L loc $ WithUserRdr rdr_name name + ; let loc_gre_with_rdr = L loc $ WithUserRdr rdr_name gre + name = greName gre ; if | explicit_level_imports -- See Note [Strict level checks with ExplicitLevelImports] - -> checkThLocalNameNoLift loc_name_with_rdr + -> checkThLocalNameNoLift loc_gre_with_rdr | nameIsLocalOrFrom this_mod name - -> checkThLocalTyName name + -> checkThLocalTyName gre | otherwise -> pure () - ; checkPromotedDataConName env tv Prefix ip name - ; return (HsTyVar noAnn ip loc_name_with_rdr, unitFN name) } + ; checkPromotedDataConName env tv Prefix ip $ greName gre + ; return (HsTyVar noAnn ip $ fmap greName <$> loc_gre_with_rdr, unitFN name) } rnHsTyKi env ty@(HsOpTy _ ty1 tyop ty2) = setSrcSpan (getLocA tyop) $ @@ -826,13 +827,13 @@ throw an error accordingly. -} -------------- -rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name +rnTyVar :: RnTyKiEnv -> RdrName -> RnM GlobalRdrElt rnTyVar env rdr_name - = do { name <- lookupTypeOccRn rdr_name - ; checkNamedWildCard env name - ; return name } + = do { gre <- lookupTypeOccRn rdr_name + ; checkNamedWildCard env $ greName gre + ; return gre } -rnLTyVar :: LocatedN RdrName -> RnM (LocatedN Name) +rnLTyVar :: LocatedN RdrName -> RnM (LocatedN GlobalRdrElt) -- Called externally; does not deal with wildcards rnLTyVar (L loc rdr_name) = do { tyvar <- lookupTypeOccRn rdr_name @@ -843,14 +844,15 @@ rnHsTyOp :: RnTyKiEnv -> HsType GhcPs -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeNames) rnHsTyOp env overall_ty tyop | L l (HsTyVar ann prom (L loc op)) <- tyop - = do { op' <- rnTyVar env op + = do { opgre <- rnTyVar env op + ; let opName = greName opgre ; unlessXOptM LangExt.TypeOperators $ - if (op' `hasKey` eqTyConKey) -- See [eqTyCon (~) compatibility fallback] in GHC.Rename.Env + if opName `hasKey` eqTyConKey -- See [eqTyCon (~) compatibility fallback] in GHC.Rename.Env then addDiagnostic TcRnTypeEqualityRequiresOperators else addErr $ TcRnIllegalTypeOperator (ppr overall_ty) op - ; checkPromotedDataConName env overall_ty Infix prom op' - ; let tyop' = L l (HsTyVar ann prom (L loc (WithUserRdr op op'))) - ; return (tyop', unitFN op') } + ; checkPromotedDataConName env overall_ty Infix prom opName + ; let tyop' = L l (HsTyVar ann prom (L loc (WithUserRdr op opName))) + ; return (tyop', unitFN opName) } | otherwise = rnLHsTyKi env tyop ===================================== compiler/GHC/Rename/Module.hs ===================================== @@ -2491,8 +2491,8 @@ rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv)) bindLocalNames (maybeToList (hsLTyVarName resTv)) $ -- The return type variable scopes over the injectivity annotation -- e.g. type family F a = (r::*) | r -> a - do { injFrom' <- rnLTyVar injFrom - ; injTo' <- mapM rnLTyVar injTo + do { injFrom' <- fmap greName <$> rnLTyVar injFrom + ; injTo' <- mapM (fmap (fmap greName) . rnLTyVar) injTo -- Note: srcSpan is unchanged, but typechecker gets -- confused, l2l call makes it happy ; return $ L (l2l srcSpan) (InjectivityAnn x injFrom' injTo') } @@ -2533,7 +2533,7 @@ rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn x injFrom injTo)) = (injDecl', _) <- askNoErrs $ do injFrom' <- rnLTyVar injFrom injTo' <- mapM rnLTyVar injTo - return $ L srcSpan (InjectivityAnn x injFrom' injTo') + return $ L srcSpan (InjectivityAnn x (fmap greName injFrom') (fmap (fmap greName) injTo')) return $ injDecl' {- ===================================== compiler/GHC/Rename/Pat.hs ===================================== @@ -1296,7 +1296,8 @@ wrapSrcSpanTPRnM fn (L loc a) = do lookupTypeOccTPRnM :: RdrName -> TPRnM Name lookupTypeOccTPRnM rdr_name = liftRnFV $ do - name <- lookupTypeOccRn rdr_name + gre <- lookupTypeOccRn rdr_name + let name = greName gre pure (name, unitFN name) rn_lty_pat :: LHsType GhcPs -> TPRnM (LHsType GhcRn) ===================================== compiler/GHC/Rename/Splice.hs ===================================== @@ -1,5 +1,4 @@ {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultiWayIf #-} module GHC.Rename.Splice ( rnTopSpliceDecls, @@ -40,7 +39,7 @@ import GHC.Unit.Module import GHC.Types.SrcLoc import GHC.Rename.HsType ( rnLHsType ) -import Control.Monad ( unless, when ) +import Control.Monad ( unless, when, void ) import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr ) @@ -182,11 +181,12 @@ rnUntypedBracket e br_body rn_utbracket :: HsQuote GhcPs -> RnM (HsQuote GhcRn, FreeNames) rn_utbracket (VarBr _ is_value_name rdr_name) - = do { name <- lookupOccRn (if is_value_name then WL_Term else WL_Type) (unLoc rdr_name) - ; let res_name = L (l2l (locA rdr_name)) (WithUserRdr (unLoc rdr_name) name) - ; if is_value_name then checkThLocalNameNoLift res_name else checkThLocalTyName name - ; check_namespace is_value_name name - ; return (VarBr noExtField is_value_name (noLocA name), unitFN name) } + = do { gre <- lookupOccRnGRE (if is_value_name then WL_Term else WL_Type) (unLoc rdr_name) + ; let res_name = L (l2l (locA rdr_name)) (WithUserRdr (unLoc rdr_name) gre) + ; let name = greName gre + ; if is_value_name then checkThLocalNameNoLift res_name else checkThLocalTyName gre + ; check_namespace is_value_name $ greName gre + ; return (VarBr noExtField is_value_name (fmap (greName . unwrapUserRdr) res_name), unitFN name) } rn_utbracket (ExpBr _ e) = do { (e', fvs) <- rnLExpr e ; return (ExpBr noExtField e', fvs) } @@ -431,10 +431,11 @@ rnUntypedSplice (HsUntypedSpliceExpr _ expr) flavour rnUntypedSplice (HsQuasiQuote _ quoter quote) flavour = do { -- Rename the quoter; akin to the HsVar case of rnExpr - ; quoter' <- lookupLocatedOccRn WL_TermVariable quoter + ; quoter' <- lookupLocatedOccRnGRE WL_TermVariable quoter ; let res_name = WithUserRdr (unLoc quoter) <$> quoter' ; checkThLocalNameNoLift res_name - ; return (HsQuasiQuote (HsQuasiQuoteExt flavour) quoter' quote, unitFN (unLoc quoter')) } + ; let loc_name = fmap greName quoter' + ; return (HsQuasiQuote (HsQuasiQuoteExt flavour) loc_name quote, unitFN (unLoc loc_name)) } --------------------- rnTypedSplice :: HsTypedSplice GhcPs -- Typed splice expression @@ -907,14 +908,14 @@ traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src = vcat [ text "--" <+> ppr loc <> colon <+> text "Splicing" <+> text sd , gen ] -checkThLocalTyName :: Name -> RnM () -checkThLocalTyName name +checkThLocalTyName :: GlobalRdrElt -> RnM () +checkThLocalTyName gre | isUnboundName name -- Do not report two errors for = return () -- $(not_in_scope args) | otherwise = do { traceRn "checkThLocalTyName" (ppr name) - ; mb_local_use <- getCurrentAndBindLevel name + ; mb_local_use <- getCurrentAndBindLevel gre ; case mb_local_use of { Nothing -> return () ; -- Not a locally-bound thing Just (top_lvl, bind_lvl, use_lvl) -> @@ -932,28 +933,29 @@ checkThLocalTyName name <+> ppr use_lvl) ; dflags <- getDynFlags ; checkCrossLevelLiftingTy dflags top_lvl bind_lvl use_lvl name } } } + where name = greName gre -- | Check whether we are allowed to use a Name in this context (for TH purposes) -- In the case of a level incorrect program, attempt to fix it by using -- a Lift constraint. -checkThLocalNameWithLift :: LIdOccP GhcRn -> RnM (HsExpr GhcRn) +checkThLocalNameWithLift :: LocatedN (WithUserRdr GlobalRdrElt) -> RnM (HsExpr GhcRn) checkThLocalNameWithLift = checkThLocalName True -- | Check whether we are allowed to use a Name in this context (for TH purposes) -- In the case of a level incorrect program, do not attempt to fix it by using -- a Lift constraint. -checkThLocalNameNoLift :: LIdOccP GhcRn -> RnM () -checkThLocalNameNoLift name = checkThLocalName False name >> return () +checkThLocalNameNoLift :: LocatedN (WithUserRdr GlobalRdrElt) -> RnM () +checkThLocalNameNoLift = void . checkThLocalName False -- | Implementation of the level checks -- See Note [Template Haskell levels] -checkThLocalName :: Bool -> LIdOccP GhcRn -> RnM (HsExpr GhcRn) -checkThLocalName allow_lifting name_var +checkThLocalName :: Bool -> LocatedN (WithUserRdr GlobalRdrElt) -> RnM (HsExpr GhcRn) +checkThLocalName allow_lifting loc_gre -- Exact and Orig names are not imported, so presumed available at all levels. -- whenever the user uses exact names, e.g. say @'mkNameG_v' "" "Foo" "bar"@, -- even though the 'mkNameG_v' here is essentially a quotation, we do not do -- level checks as we assume that the user was trying to bypass the level checks - | isExact (userRdrName (unLoc name_var)) || isOrig (userRdrName (unLoc name_var)) + | isExact rdr || isOrig rdr = return (HsVar noExtField name_var) | isUnboundName name -- Do not report two errors for = return (HsVar noExtField name_var) -- $(not_in_scope args) @@ -961,7 +963,7 @@ checkThLocalName allow_lifting name_var = return (HsVar noExtField name_var) | otherwise = do { - mb_local_use <- getCurrentAndBindLevel name + mb_local_use <- getCurrentAndBindLevel $ unwrap loc_gre ; case mb_local_use of { Nothing -> return (HsVar noExtField name_var) ; -- Not a locally-bound thing Just (top_lvl, bind_lvl, use_lvl) -> @@ -969,13 +971,12 @@ checkThLocalName allow_lifting name_var ; let is_local | Just mod <- nameModule_maybe name = mod == cur_mod | otherwise = True - ; traceRn "checkThLocalName" (ppr name <+> ppr bind_lvl <+> ppr use_lvl) ; dflags <- getDynFlags - ; env <- getGlobalRdrEnv - ; let mgre = lookupGRE_Name env name - ; checkCrossLevelLifting dflags (LevelCheckSplice name mgre) top_lvl is_local allow_lifting bind_lvl use_lvl name_var } } } - where - name = getName name_var + ; checkCrossLevelLifting dflags (LevelCheckSplice $ unLoc loc_gre) top_lvl is_local allow_lifting bind_lvl use_lvl name_var } } } + where rdr = userRdrName $ unLoc name_var + name_var = fmap greName <$> loc_gre + name = unwrap name_var + unwrap = unwrapUserRdr . unLoc -------------------------------------- checkCrossLevelLifting :: DynFlags @@ -1013,12 +1014,14 @@ checkCrossLevelLifting dflags reason top_lvl_flg is_local allow_lifting bind_lvl , any (\bind_idx -> use_lvl_idx == incThLevelIndex bind_idx) (Set.toList bind_lvl) , allow_lifting = do - let mgre = case reason of - LevelCheckSplice _ gre -> gre - _ -> Nothing + let gre + | LevelCheckSplice rdr <- reason + = Just $! unwrapUserRdr rdr + | otherwise + = Nothing (splice_name :: Name) <- newLocalBndrRn (noLocA unqualSplice) let pend_splice :: HsImplicitLiftSplice - pend_splice = HsImplicitLiftSplice bind_lvl use_lvl_idx mgre name_var + pend_splice = HsImplicitLiftSplice bind_lvl use_lvl_idx gre name_var -- Warning for implicit lift (#17804) addDetailedDiagnostic (TcRnImplicitLift name) ===================================== compiler/GHC/Rename/Splice.hs-boot ===================================== @@ -2,7 +2,7 @@ module GHC.Rename.Splice where import GHC.Hs import GHC.Tc.Utils.Monad -import GHC.Types.Name (Name) +import GHC.Types.Name.Reader (WithUserRdr, GlobalRdrElt) import GHC.Types.Name.Set @@ -15,6 +15,6 @@ rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeNames) rnTopSpliceDecls :: HsUntypedSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeNames) -checkThLocalTyName :: Name -> RnM () +checkThLocalTyName :: GlobalRdrElt -> RnM () -checkThLocalNameNoLift :: LIdOccP GhcRn -> RnM () +checkThLocalNameNoLift :: LocatedN (WithUserRdr GlobalRdrElt) -> RnM () ===================================== compiler/GHC/Rename/Unbound.hs ===================================== @@ -11,6 +11,7 @@ module GHC.Rename.Unbound , mkUnboundNameRdr , mkUnboundGRE , mkUnboundGRERdr + , mkUnboundGREName , isUnboundName , reportUnboundName , unknownNameSuggestions @@ -24,6 +25,8 @@ module GHC.Rename.Unbound , LookingFor(..) , unboundName , unboundNameX + , unboundGRE + , unboundGREX , unboundTermNameInTypes , IsTermInTypes(..) , notInScopeErr @@ -102,14 +105,23 @@ mkUnboundNameRdr :: RdrName -> Name mkUnboundNameRdr rdr = mkUnboundName (rdrNameOcc rdr) mkUnboundGRE :: OccName -> GlobalRdrElt -mkUnboundGRE occ = mkLocalGRE UnboundGRE NoParent $ mkUnboundName occ +mkUnboundGRE occ = mkUnboundGREName $ mkUnboundName occ mkUnboundGRERdr :: RdrName -> GlobalRdrElt -mkUnboundGRERdr rdr = mkLocalGRE UnboundGRE NoParent $ mkUnboundNameRdr rdr +mkUnboundGRERdr rdr = mkUnboundGREName $ mkUnboundNameRdr rdr + +mkUnboundGREName :: Name -> GlobalRdrElt +mkUnboundGREName = mkLocalGRE UnboundGRE NoParent reportUnboundName :: WhatLooking -> RdrName -> RnM Name reportUnboundName what_look rdr = unboundName (LF what_look WL_Anywhere) rdr +unboundGRE :: LookingFor -> RdrName -> RnM GlobalRdrElt +unboundGRE lf rdr = mkUnboundGREName <$> unboundName lf rdr + +unboundGREX :: LookingFor -> RdrName -> [GhcHint] -> RnM GlobalRdrElt +unboundGREX lf rdr hints = mkUnboundGREName <$> unboundNameX lf rdr hints + unboundName :: LookingFor -> RdrName -> RnM Name unboundName lf rdr = unboundNameX lf rdr [] ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -1188,8 +1188,14 @@ mkImplicitLiftingReporter ctxt mkImplicitLiftingError :: ErrorItem -> TcRnMessage mkImplicitLiftingError item = case errorItemOrigin item of - ImplicitLiftOrigin (HsImplicitLiftSplice bound used gre name) -> - TcRnBadlyLevelled (LevelCheckSplice (getName name) gre) bound used (Just item) (cec_defer_type_errors ctxt) + -- mgre is Nothing IFF LevelCheckReason is LevelCheckInstance + ImplicitLiftOrigin (HsImplicitLiftSplice bound used (Just gre) loc_name) -> + TcRnBadlyLevelled + (LevelCheckSplice $ gre <$ unLoc loc_name) + bound + used + (Just item) + (cec_defer_type_errors ctxt) _ -> pprPanic "mkImplicitLiftingError" (ppr item) mkGivenErrorReporter :: Reporter ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -3465,12 +3465,16 @@ pprTcRnBadlyLevelled reason bind_lvls use_lvl lift_attempt = mkDecorated $ (text "No instance for:" <+> quotes (ppr (errorItemPred item))) | Just item <- [lift_attempt] ] ++ - [ vcat (text "Available from the imports:" : ppr_imports (gre_imp gre)) - | LevelCheckSplice _ (Just gre) <- [reason] + [ ppr_imports (gre_imp gre) + | LevelCheckSplice (unwrapUserRdr -> gre) <- [reason] , not (isEmptyBag (gre_imp gre)) ] where - ppr_imports :: Bag ImportSpec -> [SDoc] - ppr_imports = map ((bullet <+>) . ppr ) . bagToList + ppr_imports :: Bag ImportSpec -> SDoc + ppr_imports bag + | [imp] <- impspecs = pprImpSpec imp + | otherwise = vcat $ text "Available from the imports:" : map ((bullet <+>) . pprImpSpec) impspecs + where impspecs = bagToList bag + pprImpSpec imp = ppr imp note :: SDoc -> SDoc note note = "Note" <> colon <+> note <> dot @@ -6250,8 +6254,8 @@ pprLevelCheckReason :: LevelCheckReason -> SDoc pprLevelCheckReason = \case LevelCheckInstance _ t -> text "instance for" <+> quotes (ppr t) - LevelCheckSplice t _ -> - quotes (ppr t) + LevelCheckSplice t -> + quotes $ ppr $ userRdrName t pprUninferrableTyVarCtx :: UninferrableTyVarCtx -> SDoc pprUninferrableTyVarCtx = \case ===================================== compiler/GHC/Tc/Errors/Types.hs ===================================== @@ -6338,7 +6338,7 @@ data WrongThingSort data LevelCheckReason = LevelCheckInstance !InstanceWhat !PredType - | LevelCheckSplice !Name !(Maybe GlobalRdrElt) + | LevelCheckSplice !(WithUserRdr GlobalRdrElt) data UninferrableTyVarCtx = UninfTyCtx_ClassContext [TcType] ===================================== compiler/GHC/Tc/Gen/Export.hs ===================================== @@ -540,7 +540,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod let avail = availFromGRE gre name = greName gre - checkThLocalNameNoLift (ieLWrappedUserRdrName l name) + checkThLocalNameNoLift $ ieLWrappedUserRdrName l gre occs' <- check_occs occs ie [gre] (export_warn_spans', dont_warn_export', warn_txt_rn) <- process_warning export_warn_spans @@ -589,7 +589,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod occs' <- check_occs occs ie [gre] return (Just avail, occs', exp_dflts) - checkThLocalNameNoLift (ieLWrappedUserRdrName l name) + checkThLocalNameNoLift (ieLWrappedUserRdrName l gre) (export_warn_spans', dont_warn_export', warn_txt_rn) <- process_warning export_warn_spans dont_warn_export @@ -617,7 +617,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod all_gres = par : all_kids all_names = map greName all_gres - checkThLocalNameNoLift (ieLWrappedUserRdrName l name) + checkThLocalNameNoLift (ieLWrappedUserRdrName l par) occs' <- check_occs occs ie all_gres (export_warn_spans', dont_warn_export', warn_txt_rn) <- process_warning export_warn_spans @@ -656,7 +656,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod all_gres = par : all_kids all_names = map greName all_gres - checkThLocalNameNoLift (ieLWrappedUserRdrName l name) + checkThLocalNameNoLift (ieLWrappedUserRdrName l par) occs' <- check_occs occs ie all_gres (export_warn_spans', dont_warn_export', warn_txt_rn) <- process_warning export_warn_spans @@ -794,8 +794,8 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod = addUsedGREs ExportDeprecationWarnings (pickGREs parent_rdr kid_gres) -ieLWrappedUserRdrName :: LIEWrappedName GhcPs -> Name -> LIdOccP GhcRn -ieLWrappedUserRdrName l n = fmap (\rdr -> WithUserRdr rdr n) $ ieLWrappedName l +ieLWrappedUserRdrName :: LIEWrappedName GhcPs -> n -> GenLocated SrcSpanAnnN (WithUserRdr n) +ieLWrappedUserRdrName l n = (\rdr -> WithUserRdr rdr n) <$> ieLWrappedName l -- | In what namespaces should we go looking for an import/export item -- that is out of scope, for suggestions in error messages? @@ -901,7 +901,7 @@ lookupChildrenExport parent_gre child_gres rdr_items = mapAndReportM doOne rdr_i ; return (replaceLWrappedName n ub, gre)} FoundChild child@(GRE { gre_name = child_nm, gre_par = par }) -> do { checkPatSynParent spec_parent par child_nm - ; checkThLocalNameNoLift (ieLWrappedUserRdrName n child_nm) + ; checkThLocalNameNoLift (ieLWrappedUserRdrName n child) ; return (replaceLWrappedName n child_nm, child) } IncorrectParent p c gs -> failWithDcErr (parentGRE_name p) (greName c) gs ===================================== compiler/GHC/Tc/Utils/Env.hs ===================================== @@ -135,7 +135,7 @@ import GHC.Types.Unique.Set ( nonDetEltsUniqSet ) import qualified GHC.LanguageExtensions as LangExt import GHC.Iface.Errors.Types -import GHC.Rename.Unbound ( unknownNameSuggestions ) +import GHC.Rename.Unbound ( unknownNameSuggestions, mkUnboundGREName ) import GHC.Tc.Errors.Types.PromotionErr import {-# SOURCE #-} GHC.Tc.Errors.Hole (getHoleFitDispConfig) @@ -252,15 +252,12 @@ tcLookupGlobal name env <- getGblEnv ; case lookupNameEnv (tcg_type_env env) name of { Just thing -> return thing ; - Nothing -> - -- Should it have been in the local envt? -- (NB: use semantic mod here, since names never use -- identity module, see Note [Identity versus semantic module].) - if nameIsLocalOrFrom (tcg_semantic_mod env) name - then notFound name -- Internal names can happen in GHCi - else - + Nothing | nameIsLocalOrFrom (tcg_semantic_mod env) name -> + notFound $ mkUnboundGREName name -- Internal names can happen in GHCi + | otherwise -> -- Try home package table and external package table do { mb_thing <- tcLookupImported_maybe name ; case mb_thing of @@ -1221,10 +1218,10 @@ pprBinders :: [Name] -> SDoc pprBinders [bndr] = quotes (ppr bndr) pprBinders bndrs = pprWithCommas ppr bndrs -notFound :: Name -> TcM TyThing -notFound name +notFound :: GlobalRdrElt -> TcM TyThing +notFound gre = do { lcl_env <- getLclEnv - ; lvls <- getCurrentAndBindLevel name + ; lvls <- getCurrentAndBindLevel gre ; if -- See Note [Out of scope might be a staging error] | isUnboundName name -> failM -- If the name really isn't in scope -- don't report it again (#11941) @@ -1234,8 +1231,13 @@ notFound name -- introducing bugs after a refactoring of that -- function, we check this completely independently -- before scrutinizing lvls - | Just (_top_lvl_flag, bind_lvls, lvl@Splice {}) <- lvls - -> failWithTc (TcRnBadlyLevelled (LevelCheckSplice name Nothing) bind_lvls (thLevelIndex lvl) Nothing ErrorWithoutFlag) + | Just (_top_lvl_flag, bind_lvls, lvl@Splice {}) <- lvls -> failWithTc $ + TcRnBadlyLevelled + (LevelCheckSplice (gre <$ noUserRdr name)) + bind_lvls + (thLevelIndex lvl) + Nothing + ErrorWithoutFlag | otherwise -> pure () ; if isTermVarOrFieldNameSpace (nameNameSpace name) @@ -1260,6 +1262,7 @@ notFound name -- so let's just not print it! Getting a loop here is -- very unhelpful, because it hides one compiler bug with another } + where name = greName gre wrongThingErr :: WrongThingSort -> TcTyThing -> Name -> TcM a wrongThingErr expected thing name = ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -2468,32 +2468,22 @@ keepAlive name getThLevel :: TcM ThLevel getThLevel = do { env <- getLclEnv; return (getLclEnvThLevel env) } -getCurrentAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, Set.Set ThLevelIndex, ThLevel)) -getCurrentAndBindLevel name +getCurrentAndBindLevel :: GlobalRdrElt -> TcRn (Maybe (TopLevelFlag, Set.Set ThLevelIndex, ThLevel)) +getCurrentAndBindLevel gre = do { env <- getLclEnv; - ; case lookupNameEnv (getLclEnvThBndrs env) name of - Nothing -> do - lvls <- getExternalBindLvl name - if Set.empty == lvls - -- This case happens when code is generated for identifiers which are not - -- in scope. - -- - -- TODO: What happens if someone generates [|| GHC.Magic.dataToTag# ||] - then do - return Nothing - else return (Just (TopLevel, lvls, getLclEnvThLevel env)) - Just (top_lvl, bind_lvl) -> return (Just (top_lvl, Set.singleton bind_lvl, getLclEnvThLevel env)) } - -getExternalBindLvl :: Name -> TcRn (Set.Set ThLevelIndex) -getExternalBindLvl name = do - env <- getGlobalRdrEnv - mod <- getModule - case lookupGRE_Name env name of - Just gre -> return $ (Set.map thLevelIndexFromImportLevel (greLevels gre)) - Nothing -> - if nameIsLocalOrFrom mod name - then return $ Set.singleton topLevelIndex - else return Set.empty + ; return $ case lookupNameEnv (getLclEnvThBndrs env) $ greName gre of + Nothing + | Set.null lvls -> Nothing + -- This case happens when code is generated for identifiers which are not + -- in scope. + -- + -- TODO: What happens if someone generates [|| GHC.Magic.dataToTag# ||] + | otherwise -> Just (TopLevel, lvls, getLclEnvThLevel env) + Just (top_lvl, bind_lvl) -> Just (top_lvl, Set.singleton bind_lvl, getLclEnvThLevel env) } + where lvls = getExternalBindLvl gre + +getExternalBindLvl :: GlobalRdrElt -> Set.Set ThLevelIndex +getExternalBindLvl gre = Set.map thLevelIndexFromImportLevel (greLevels gre) setThLevel :: ThLevel -> TcM a -> TcRn a setThLevel l = updLclEnv (setLclEnvThLevel l) ===================================== compiler/GHC/Types/Name/Reader.hs ===================================== @@ -40,7 +40,7 @@ module GHC.Types.Name.Reader ( isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, -- ** Preserving user-written qualification - WithUserRdr(..), noUserRdr, unLocWithUserRdr, userRdrName, + WithUserRdr(..), noUserRdr, unLocWithUserRdr, userRdrName, unwrapUserRdr, -- * Local mapping of 'RdrName' to 'Name.Name' LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList, @@ -2247,9 +2247,12 @@ unLocWithUserRdr (L _ (WithUserRdr _ a)) = a noUserRdr :: Name -> WithUserRdr Name noUserRdr n = WithUserRdr (nameRdrName n) n -userRdrName :: WithUserRdr Name -> RdrName +userRdrName :: WithUserRdr a -> RdrName userRdrName (WithUserRdr rdr _) = rdr +unwrapUserRdr :: WithUserRdr a -> a +unwrapUserRdr (WithUserRdr _ a) = a + rdrQual_maybe :: RdrName -> Maybe ModuleName rdrQual_maybe = \case Qual q _ -> Just q ===================================== testsuite/tests/quotes/LiftErrMsg.stderr ===================================== @@ -2,8 +2,7 @@ LiftErrMsg.hs:14:11: error: [GHC-28914] • Level error: ‘id’ is bound at level 0 but used at level 1 • Could not be resolved by implicit lifting due to the following error: No instance for: ‘Lift (a2 -> a2)’ - • Available from the imports: - • imported from ‘Prelude’ + • imported from ‘Prelude’ • In the expression: [| id |] In an equation for ‘test’: test = [| id |] @@ -11,8 +10,7 @@ LiftErrMsg.hs:17:13: error: [GHC-28914] • Level error: ‘id’ is bound at level 0 but used at level 1 • Could not be resolved by implicit lifting due to the following error: No instance for: ‘Lift (a1 -> a1)’ - • Available from the imports: - • imported from ‘Prelude’ + • imported from ‘Prelude’ • In the expression: [| (id, id) |] In an equation for ‘test2’: test2 = [| (id, id) |] @@ -20,8 +18,7 @@ LiftErrMsg.hs:17:17: error: [GHC-28914] • Level error: ‘id’ is bound at level 0 but used at level 1 • Could not be resolved by implicit lifting due to the following error: No instance for: ‘Lift (a0 -> a0)’ - • Available from the imports: - • imported from ‘Prelude’ + • imported from ‘Prelude’ • In the expression: [| (id, id) |] In an equation for ‘test2’: test2 = [| (id, id) |] ===================================== testsuite/tests/quotes/LiftErrMsgDefer.stderr ===================================== @@ -4,12 +4,11 @@ LiftErrMsgDefer.hs:14:12: warning: [GHC-28914] [-Wdeferred-type-errors (in -Wdef • Level error: ‘id’ is bound at level 0 but used at level 1 • Could not be resolved by implicit lifting due to the following error: No instance for: ‘Lift (a2 -> a2)’ - • Available from the imports: - • imported from ‘Prelude’ + • imported from ‘Prelude’ • In the expression: [| id |] In an equation for ‘test1’: test1 = [| id |] (deferred type error) HasCallStack backtrace: - throw, called at libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs:435:30 in ghc-internal:GHC.Internal.Control.Exception.Base + throw, called at libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs:441:30 in ghc-internal:GHC.Internal.Control.Exception.Base ===================================== testsuite/tests/quotes/LiftErrMsgTyped.stderr ===================================== @@ -2,8 +2,7 @@ LiftErrMsgTyped.hs:14:12: error: [GHC-28914] • Level error: ‘id’ is bound at level 0 but used at level 1 • Could not be resolved by implicit lifting due to the following error: No instance for: ‘Lift (a -> a)’ - • Available from the imports: - • imported from ‘Prelude’ + • imported from ‘Prelude’ • In the typed Template Haskell splice: id In the Template Haskell typed quotation: [|| id ||] In the expression: [|| id ||] @@ -12,8 +11,7 @@ LiftErrMsgTyped.hs:17:14: error: [GHC-28914] • Level error: ‘id’ is bound at level 0 but used at level 1 • Could not be resolved by implicit lifting due to the following error: No instance for: ‘Lift (a -> a)’ - • Available from the imports: - • imported from ‘Prelude’ + • imported from ‘Prelude’ • In the typed Template Haskell splice: id In the expression: id In the Template Haskell typed quotation: [|| (id, id) ||] ===================================== testsuite/tests/splice-imports/SI03.stderr ===================================== @@ -1,6 +1,5 @@ SI03.hs:10:11: error: [GHC-28914] • Level error: ‘sid’ is bound at level 0 but used at level -1 - • Available from the imports: - • imported from ‘SI01A’ at SI03.hs:5:1-12 + • imported from ‘SI01A’ at SI03.hs:5:1-12 • In the untyped splice: $(sid [| pure () |]) ===================================== testsuite/tests/splice-imports/SI05.stderr ===================================== @@ -1,7 +1,6 @@ SI05.hs:10:11: error: [GHC-28914] - • Level error: ‘SI01A.sid’ is bound at level 0 but used at level -1 - • Available from the imports: - • imported from ‘SI01A’ at SI05.hs:6:1-12 + • Level error: ‘sid’ is bound at level 0 but used at level -1 + • imported from ‘SI01A’ at SI05.hs:6:1-12 • In the untyped splice: $(sid [| pure () |]) SI05.hs:10:11: error: [GHC-87543] ===================================== testsuite/tests/splice-imports/SI25.stderr ===================================== @@ -1,8 +1,7 @@ SI25.hs:16:13: error: [GHC-28914] • Level error: ‘nestedCode’ is bound at level -1 but used at level -2 - • Available from the imports: - • imported from ‘SI25Helper’ at -1 at SI25.hs:6:1-24 + • imported from ‘SI25Helper’ at -1 at SI25.hs:6:1-24 • In the untyped splice: $(nestedCode "nested") In the untyped splice: $($(nestedCode "nested")) ===================================== testsuite/tests/splice-imports/SI28.stderr ===================================== @@ -1,7 +1,6 @@ SI28.hs:8:13: error: [GHC-28914] • Level error: ‘id’ is bound at level 1 but used at level 0 - • Available from the imports: - • imported from ‘Prelude’ at 1 at SI28.hs:6:1-20 + • imported from ‘Prelude’ at 1 at SI28.hs:6:1-20 • In the Template Haskell quotation: [| id |] In the untyped splice: $([| id |]) ===================================== testsuite/tests/splice-imports/SI31.stderr ===================================== @@ -1,6 +1,5 @@ <interactive>:2:3: error: [GHC-28914] • Level error: ‘id’ is bound at level 0 but used at level -1 - • Available from the imports: - • imported from ‘Prelude’ + • imported from ‘Prelude’ • In the untyped splice: $(id [| () |]) ===================================== testsuite/tests/splice-imports/T26088.stderr ===================================== @@ -1,6 +1,5 @@ T26088A.hs:8:8: error: [GHC-28914] • Level error: ‘a’ is bound at level -1 but used at level 1 - • Available from the imports: - • imported from ‘T26088B’ at -1 at T26088A.hs:4:1-21 + • imported from ‘T26088B’ at -1 at T26088A.hs:4:1-21 • In the Template Haskell quotation: [| a |] ===================================== testsuite/tests/splice-imports/T26090.stderr ===================================== @@ -1,16 +1,13 @@ T26090.hs:2:17: error: [GHC-28914] • Level error: ‘a’ is bound at level 1 but used at level 0 - • Available from the imports: - • imported from ‘T26090A’ at 1 at T26090.hs:8:1-20 + • imported from ‘T26090A’ at 1 at T26090.hs:8:1-20 T26090.hs:4:17: error: [GHC-28914] • Level error: ‘s’ is bound at level 1 but used at level 0 - • Available from the imports: - • imported from ‘T26090A’ at 1 at T26090.hs:8:1-20 + • imported from ‘T26090A’ at 1 at T26090.hs:8:1-20 • In the export: S(s) T26090.hs:5:17: error: [GHC-28914] • Level error: ‘R’ is bound at level 1 but used at level 0 - • Available from the imports: - • imported from ‘T26090A’ at 1 at T26090.hs:8:1-20 + • imported from ‘T26090A’ at 1 at T26090.hs:8:1-20 ===================================== testsuite/tests/splice-imports/T26616.hs ===================================== @@ -0,0 +1,8 @@ +{-# LANGUAGE ExplicitLevelImports, NoImplicitPrelude #-} +module T26616 where + +import quote Data.Maybe qualified as Q +import Data.Maybe qualified as Z +import splice Data.Maybe qualified as S + +foo = Q.isJust ===================================== testsuite/tests/splice-imports/T26616.stderr ===================================== @@ -0,0 +1,4 @@ +T26616.hs:8:7: error: [GHC-28914] + • Level error: ‘Q.isJust’ is bound at level 1 but used at level 0 + • imported qualified from ‘Data.Maybe’ at 1 at T26616.hs:4:1-39 + ===================================== testsuite/tests/splice-imports/all.T ===================================== @@ -52,3 +52,4 @@ test('T26090', [], multimod_compile_fail, ['T26090', '-v0']) test('ModuleExport', [], multimod_compile_fail, ['ModuleExport', '-v0']) test('LevelImportExports', [], makefile_test, []) test('DodgyLevelExport', [], multimod_compile, ['DodgyLevelExport', '-v0 -Wdodgy-exports']) +test('T26616', normal, compile_fail, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/768de01f58b7ca6ab85a8fba5567bea8... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/768de01f58b7ca6ab85a8fba5567bea8... You're receiving this email because of your account on gitlab.haskell.org.