Magnus pushed to branch wip/mangoiv/26616 at Glasgow Haskell Compiler / GHC Commits: 7ffe1f5b by mangoiv at 2026-06-15T21:17:57+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 - - - - - 25 changed files: - + changelog.d/26616 - 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/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/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/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,16 @@ lookupLocalOccRn rdr_name -- lookupTypeOccRn looks up an optionally promoted RdrName. -- Used for looking up type variables. -lookupTypeOccRn :: RdrName -> RnM Name +lookupTypeOccRn :: RdrName -> RnM (MayGRE GREInfo) -- see Note [Demotion] lookupTypeOccRn rdr_name = do { mb_gre <- lookupOccRn_maybe rdr_name ; case mb_gre of - Just gre -> return $ greName gre + Just gre -> return $ Right $! gre Nothing -> if occName rdr_name == occName eqTyCon_RDR -- See Note [eqTyCon (~) compatibility fallback] - then eqTyConName <$ addDiagnostic TcRnTypeEqualityOutOfScope - else lookup_demoted rdr_name } + then (Left $! eqTyConName) <$ addDiagnostic TcRnTypeEqualityOutOfScope + else Left <$!> lookup_demoted rdr_name } {- Note [eqTyCon (~) compatibility fallback] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== 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 $ Right $! 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 $ Right $! 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 + ; mgre <- 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_mgre_with_rdr = L loc $ WithUserRdr rdr_name mgre + name = mgreName mgre ; if | explicit_level_imports -- See Note [Strict level checks with ExplicitLevelImports] - -> checkThLocalNameNoLift loc_name_with_rdr + -> checkThLocalNameNoLift loc_mgre_with_rdr | nameIsLocalOrFrom this_mod name - -> checkThLocalTyName name + -> checkThLocalTyName mgre | otherwise -> pure () - ; checkPromotedDataConName env tv Prefix ip name - ; return (HsTyVar noAnn ip loc_name_with_rdr, unitFN name) } + ; checkPromotedDataConName env tv Prefix ip $ mgreName mgre + ; return (HsTyVar noAnn ip $ fmap mgreName <$> loc_mgre_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 (MayGRE GREInfo) rnTyVar env rdr_name - = do { name <- lookupTypeOccRn rdr_name - ; checkNamedWildCard env name - ; return name } + = do { mgre <- lookupTypeOccRn rdr_name + ; checkNamedWildCard env $ mgreName mgre + ; return mgre } -rnLTyVar :: LocatedN RdrName -> RnM (LocatedN Name) +rnLTyVar :: LocatedN RdrName -> RnM (LocatedN (MayGRE GREInfo)) -- 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 { opmgre <- rnTyVar env op + ; let opName = mgreName opmgre ; 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 mgreName <$> rnLTyVar injFrom + ; injTo' <- mapM (fmap (fmap mgreName) . 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 mgreName injFrom') (fmap (fmap mgreName) 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 + mgre <- lookupTypeOccRn rdr_name + let name = mgreName mgre 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,13 @@ 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 mgre = Right $! gre + ; let res_name = L (l2l (locA rdr_name)) (WithUserRdr (unLoc rdr_name) mgre) + ; let name = greName gre + ; if is_value_name then checkThLocalNameNoLift res_name else checkThLocalTyName mgre + ; check_namespace is_value_name $ greName gre + ; return (VarBr noExtField is_value_name (fmap (mgreName . unwrapUserRdr) res_name), unitFN name) } rn_utbracket (ExpBr _ e) = do { (e', fvs) <- rnLExpr e ; return (ExpBr noExtField e', fvs) } @@ -431,10 +432,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 - ; let res_name = WithUserRdr (unLoc quoter) <$> quoter' + ; quoter' <- lookupLocatedOccRnGre WL_TermVariable quoter + ; let res_name = WithUserRdr (unLoc quoter) . (Right $!) <$> 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 +909,14 @@ traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src = vcat [ text "--" <+> ppr loc <> colon <+> text "Splicing" <+> text sd , gen ] -checkThLocalTyName :: Name -> RnM () -checkThLocalTyName name +checkThLocalTyName :: MayGRE w -> RnM () +checkThLocalTyName mgre | 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 mgre ; case mb_local_use of { Nothing -> return () ; -- Not a locally-bound thing Just (top_lvl, bind_lvl, use_lvl) -> @@ -932,28 +934,29 @@ checkThLocalTyName name <+> ppr use_lvl) ; dflags <- getDynFlags ; checkCrossLevelLiftingTy dflags top_lvl bind_lvl use_lvl name } } } + where name = mgreName mgre -- | 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 (MayGRE GREInfo)) -> 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 (MayGRE GREInfo)) -> 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 (MayGRE GREInfo)) -> RnM (HsExpr GhcRn) +checkThLocalName allow_lifting mgre -- 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 +964,7 @@ checkThLocalName allow_lifting name_var = return (HsVar noExtField name_var) | otherwise = do { - mb_local_use <- getCurrentAndBindLevel name + mb_local_use <- getCurrentAndBindLevel $ unwrap mgre ; 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 +972,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 mgre) top_lvl is_local allow_lifting bind_lvl use_lvl name_var } } } + where rdr = userRdrName $ unLoc name_var + name_var = fmap mgreName <$> mgre + name = unwrap name_var + unwrap = unwrapUserRdr . unLoc -------------------------------------- checkCrossLevelLifting :: DynFlags @@ -1013,9 +1015,12 @@ 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 mgre + | LevelCheckSplice rdr <- reason + , Right gre <- unwrapUserRdr rdr + = Just $! gre + | otherwise + = Nothing (splice_name :: Name) <- newLocalBndrRn (noLocA unqualSplice) let pend_splice :: HsImplicitLiftSplice pend_splice = HsImplicitLiftSplice bind_lvl use_lvl_idx mgre name_var ===================================== 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, GREInfo) 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 :: MayGRE w -> RnM () -checkThLocalNameNoLift :: LIdOccP GhcRn -> RnM () +checkThLocalNameNoLift :: LocatedN (WithUserRdr (MayGRE GREInfo)) -> RnM () ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -1188,8 +1188,13 @@ 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) + ImplicitLiftOrigin (HsImplicitLiftSplice bound used mgre loc_name) -> + TcRnBadlyLevelled + (LevelCheckSplice $ maybe (Left $! getName loc_name) (Right $!) mgre <$ 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 -> Right 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 (Either Name 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 $ Right $! 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 $ Right $! 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 $ Right $! 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 $ Right $! 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 $ Right $! child) ; return (replaceLWrappedName n child_nm, child) } IncorrectParent p c gs -> failWithDcErr (parentGRE_name p) (greName c) gs ===================================== compiler/GHC/Tc/Utils/Env.hs ===================================== @@ -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 (Left 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 :: MayGRE GREInfo -> TcM TyThing +notFound mgre = do { lcl_env <- getLclEnv - ; lvls <- getCurrentAndBindLevel name + ; lvls <- getCurrentAndBindLevel mgre ; 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) @@ -1235,7 +1232,13 @@ notFound name -- 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) + , let name = mgreName mgre -> failWithTc $ + TcRnBadlyLevelled + (LevelCheckSplice (mgre <$ noUserRdr name)) + bind_lvls + (thLevelIndex lvl) + Nothing + ErrorWithoutFlag | otherwise -> pure () ; if isTermVarOrFieldNameSpace (nameNameSpace name) @@ -1260,6 +1263,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 = mgreName mgre wrongThingErr :: WrongThingSort -> TcTyThing -> Name -> TcM a wrongThingErr expected thing name = ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -127,7 +127,7 @@ module GHC.Tc.Utils.Monad( -- * Template Haskell context recordThUse, recordThNeededRuntimeDeps, keepAlive, getThLevel, getCurrentAndBindLevel, setThLevel, - addModFinalizersWithLclEnv, + addModFinalizersWithLclEnv, MayGRE, mgreName, mgreGRE, -- * Safe Haskell context recordUnsafeInfer, finalSafeMode, fixSafeInstances, @@ -2468,32 +2468,40 @@ keepAlive name getThLevel :: TcM ThLevel getThLevel = do { env <- getLclEnv; return (getLclEnvThLevel env) } -getCurrentAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, Set.Set ThLevelIndex, ThLevel)) -getCurrentAndBindLevel name +getCurrentAndBindLevel :: MayGRE w -> TcRn (Maybe (TopLevelFlag, Set.Set ThLevelIndex, ThLevel)) +getCurrentAndBindLevel mgre = do { env <- getLclEnv; - ; case lookupNameEnv (getLclEnvThBndrs env) name of + ; case lookupNameEnv (getLclEnvThBndrs env) $ mgreName mgre 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)) + lvls <- getExternalBindLvl mgre + let res + | 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) + return res 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 +getExternalBindLvl :: MayGRE w -> TcRn (Set.Set ThLevelIndex) +getExternalBindLvl mgre = do 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 mgre of + Right gre -> Set.map thLevelIndexFromImportLevel (greLevels gre) + Left name + | nameIsLocalOrFrom mod name -> Set.singleton topLevelIndex + | otherwise -> Set.empty + +-- | @'GlobalRdrEltX' w@ if we have on, 'Name' otherwise +type MayGRE w = Either Name (GlobalRdrEltX w) + +mgreName :: MayGRE w -> Name +mgreName = either id greName + +mgreGRE :: MayGRE w -> Maybe (GlobalRdrEltX w) +mgreGRE = either (const Nothing) Just 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/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/7ffe1f5bce25424bd0e5c096768320f9... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7ffe1f5bce25424bd0e5c096768320f9... You're receiving this email because of your account on gitlab.haskell.org.