Matthew Pickering pushed to branch wip/improve-implicit-lifting-error at Glasgow Haskell Compiler / GHC Commits: fe034312 by Matthew Pickering at 2025-05-13T16:17:34+01:00 Improve error messages when implicit lifting fails This patch concerns programs which automatically try to fix level errors by inserting `Lift`. For example: ``` foo x = [| x |] ~> foo x = [| $(lift x) |] ``` Before, there were two problems with the message. 1. (#26031), the location of the error was reported as the whole quotation. 2. (#26035), the message just mentions there is no Lift instance, but gives no indicate why the user program needed a Lift instance in the first place. This problem is especially bad when you disable `ImplicitStagePersistence`, so you just end up with a confusing "No instance for" message rather than an error message about levels This patch fixes both these issues. Firstly, `PendingRnSplice` differentiates between a user-written splice and an implicit lift. Then, the Lift instance is precisely requested with a specific origin in the typechecker. If the instance fails to be solved, the message is reported using the `TcRnBadlyLevelled` constructor (like a normal level error). Fixes #26031, #26035 - - - - - 17 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Splice.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Types/ThLevelIndex.hs - + testsuite/tests/quotes/LiftErrMsg.hs - + testsuite/tests/quotes/LiftErrMsg.stderr - + testsuite/tests/quotes/LiftErrMsgDefer.hs - + testsuite/tests/quotes/LiftErrMsgDefer.stderr - testsuite/tests/quotes/all.T - testsuite/tests/th/TH_Lift.stderr Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -55,6 +55,7 @@ import GHC.Types.SourceText import GHC.Types.SrcLoc import GHC.Types.Tickish (CoreTickish) import GHC.Types.Unique.Set (UniqSet) +import GHC.Types.ThLevelIndex import GHC.Core.ConLike ( conLikeName, ConLike ) import GHC.Unit.Module (ModuleName) import GHC.Utils.Misc @@ -78,7 +79,7 @@ import Data.Foldable ( toList ) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import Data.Void (Void) - +import qualified Data.Set as S {- ********************************************************************* * * Expressions proper @@ -2252,8 +2253,12 @@ data UntypedSpliceFlavour deriving Data -- | Pending Renamer Splice +-- There are two types of pending splices: +-- 1. A splice explicitly written by the user, e.g. `[| $(foo) |]` +-- 2. A cross-stage reference which we will attempt to fix by using Lift. data PendingRnSplice = PendingRnSplice UntypedSpliceFlavour SplicePointName (LHsExpr GhcRn) + | PendingImplicitLift (S.Set ThLevelIndex) ThLevelIndex (Maybe GlobalRdrElt) (LIdOccP GhcRn) -- | Pending Type-checker Splice data PendingTcSplice @@ -2346,6 +2351,7 @@ thTyBrackets pp_body = text "[||" <+> pp_body <+> text "||]" instance Outputable PendingRnSplice where ppr (PendingRnSplice _ n e) = pprPendingSplice n e + ppr (PendingImplicitLift _bound _used _gre n) = text "implicit lift:" <+> ppr n instance Outputable PendingTcSplice where ppr (PendingTcSplice n e) = pprPendingSplice n e ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -2027,6 +2027,7 @@ instance ToHie (HsQuote GhcRn) where instance ToHie PendingRnSplice where toHie (PendingRnSplice _ _ e) = toHie e + toHie (PendingImplicitLift _bound _used _gre l) = toHie @(LHsExpr GhcRn) (L (l2l (getLoc l)) (HsVar noExtField l)) instance ToHie PendingTcSplice where toHie (PendingTcSplice _ e) = toHie e ===================================== compiler/GHC/Rename/Expr.hs ===================================== @@ -328,7 +328,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 - ; unless (isExact v || isOrig v) $ checkThLocalNameWithLift sel_name + ; unless (isExact v || isOrig v) $ checkThLocalNameWithLift (L (l2l l) (WithUserRdr v sel_name)) ; return (XExpr (HsRecSelRn (FieldOcc v (L l sel_name))), unitFV sel_name) } | nm == nilDataConName @@ -339,8 +339,9 @@ rnExpr (HsVar _ (L l v)) -> rnExpr (ExplicitList noAnn []) | otherwise - -> do { unless (isExact v || isOrig v) (checkThLocalNameWithLift nm) - ; return (HsVar noExtField (L (l2l l) (WithUserRdr v nm)), unitFV nm) } + -> do { let res_name = L (l2l l) (WithUserRdr v nm) + ; unless (isExact v || isOrig v) (checkThLocalNameWithLift res_name) + ; return (HsVar noExtField res_name, unitFV nm) } }}} ===================================== compiler/GHC/Rename/Splice.hs ===================================== @@ -51,7 +51,7 @@ import GHC.Data.FastString import GHC.Utils.Logger import GHC.Utils.Panic import GHC.Driver.Hooks -import GHC.Builtin.Names.TH ( decsQTyConName, expQTyConName, liftName +import GHC.Builtin.Names.TH ( decsQTyConName, expQTyConName , patQTyConName, quoteDecName, quoteExpName , quotePatName, quoteTypeName, typeQTyConName) @@ -184,7 +184,8 @@ rnUntypedBracket e br_body rn_utbracket :: HsQuote GhcPs -> RnM (HsQuote GhcRn, FreeVars) rn_utbracket (VarBr _ flg rdr_name) = do { name <- lookupOccRn (if flg then WL_Term else WL_Type) (unLoc rdr_name) - ; if flg then checkThLocalNameNoLift name else checkThLocalTyName name + ; let res_name = L (l2l (locA rdr_name)) (WithUserRdr (unLoc rdr_name) name) + ; if flg then checkThLocalNameNoLift res_name else checkThLocalTyName name ; check_namespace flg name ; return (VarBr noExtField flg (noLocA name), unitFV name) } @@ -423,9 +424,10 @@ rnUntypedSplice (HsUntypedSpliceExpr annCo expr) rnUntypedSplice (HsQuasiQuote ext quoter quote) = do { -- Rename the quoter; akin to the HsVar case of rnExpr ; quoter' <- lookupOccRn WL_TermVariable quoter + ; let res_name = noLocA (WithUserRdr quoter quoter') ; this_mod <- getModule ; when (nameIsLocalOrFrom this_mod quoter') $ - checkThLocalNameNoLift quoter' + checkThLocalNameNoLift res_name ; return (HsQuasiQuote ext quoter' quote, unitFV quoter') } @@ -932,17 +934,17 @@ checkThLocalTyName name -- | 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 :: Name -> RnM () +checkThLocalNameWithLift :: LIdOccP GhcRn -> RnM () 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 :: Name -> RnM () +checkThLocalNameNoLift :: LIdOccP GhcRn -> RnM () checkThLocalNameNoLift = checkThLocalName False -checkThLocalName :: Bool -> Name -> RnM () -checkThLocalName allow_lifting name +checkThLocalName :: Bool -> LIdOccP GhcRn -> RnM () +checkThLocalName allow_lifting name_var | isUnboundName name -- Do not report two errors for = return () -- $(not_in_scope args) @@ -964,7 +966,9 @@ checkThLocalName allow_lifting name ; 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 use_lvl_idx name } } } + ; checkCrossLevelLifting dflags (LevelCheckSplice name mgre) top_lvl is_local allow_lifting bind_lvl use_lvl use_lvl_idx name_var } } } + where + name = getName name_var -------------------------------------- checkCrossLevelLifting :: DynFlags @@ -975,8 +979,8 @@ checkCrossLevelLifting :: DynFlags -> Set.Set ThLevelIndex -> ThLevel -> ThLevelIndex - -> Name -> TcM () -checkCrossLevelLifting dflags reason top_lvl is_local allow_lifting bind_lvl use_lvl use_lvl_idx name + -> LIdOccP GhcRn -> TcM () +checkCrossLevelLifting dflags reason top_lvl is_local allow_lifting bind_lvl use_lvl use_lvl_idx name_var -- 1. If name is in-scope, at the correct level. | use_lvl_idx `Set.member` bind_lvl = return () -- 2. Name is imported with -XImplicitStagePersistence @@ -993,52 +997,26 @@ checkCrossLevelLifting dflags reason top_lvl is_local allow_lifting bind_lvl use , any (use_lvl_idx >=) (Set.toList bind_lvl) , allow_lifting = do - dflags <- getDynFlags - check_cross_level_lifting dflags top_lvl name ps_var + let mgre = case reason of + LevelCheckSplice _ gre -> gre + _ -> Nothing + let pend_splice = PendingImplicitLift bind_lvl use_lvl_idx mgre name_var + -- Warning for implicit lift (#17804) + addDetailedDiagnostic (TcRnImplicitLift name) + + -- Update the pending splices + ps <- readMutVar ps_var + writeMutVar ps_var (pend_splice : ps) -- 5. For a typed bracket, these checks happen again later on (checkThLocalId) -- In the future we should do all the level checks here. | Brack _ RnPendingTyped <- use_lvl -- Lift for typed brackets is inserted later. , any (use_lvl_idx >=) (Set.toList bind_lvl) = return () -- Otherwise, we have a level error, report. - | otherwise = addErrTc (TcRnBadlyLevelled reason bind_lvl use_lvl_idx) - -check_cross_level_lifting :: DynFlags -> TopLevelFlag -> Name -> TcRef [PendingRnSplice] -> TcM () -check_cross_level_lifting dflags top_lvl name ps_var - | isTopLevel top_lvl - , xopt LangExt.ImplicitStagePersistence dflags - -- Top-level identifiers in this module, - -- (which have External Names) - -- are just like the imported case: - -- no need for the 'lifting' treatment - -- E.g. this is fine: - -- f x = x - -- g y = [| f 3 |] - = when (isExternalName name) (keepAlive name) - -- See Note [Keeping things alive for Template Haskell] + | otherwise = addErrTc (TcRnBadlyLevelled reason bind_lvl use_lvl_idx Nothing ErrorWithoutFlag) + where + name = getName name_var - | otherwise - = -- Nested identifiers, such as 'x' in - -- E.g. \x -> [| h x |] - -- We must behave as if the reference to x was - -- h $(lift x) - -- We use 'x' itself as the SplicePointName, used by - -- the desugarer to stitch it all back together. - -- If 'x' occurs many times we may get many identical - -- bindings of the same SplicePointName, but that doesn't - -- matter, although it's a mite untidy. - do { traceRn "checkCrossLevelLifting" (ppr name) - - -- Construct the (lift x) expression - ; let lift_expr = nlHsApp (nlHsVar liftName) (nlHsVar name) - pend_splice = PendingRnSplice UntypedExpSplice name lift_expr - - -- Warning for implicit lift (#17804) - ; addDetailedDiagnostic (TcRnImplicitLift name) - - -- Update the pending splices - ; ps <- readMutVar ps_var - ; writeMutVar ps_var (pend_splice : ps) } checkCrossLevelLiftingTy :: DynFlags -> TopLevelFlag -> Set.Set ThLevelIndex -> ThLevel -> ThLevelIndex -> Name -> TcM () checkCrossLevelLiftingTy dflags top_lvl bind_lvl _use_lvl use_lvl_idx name ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -610,6 +610,7 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics report1 = [ ("custom_error", is_user_type_error, True, mkUserTypeErrorReporter) -- (Handles TypeError and Unsatisfiable) + , ("implicit lifting", is_implicit_lifting, True, mkImplicitLiftingReporter) , given_eq_spec , ("insoluble2", utterly_wrong, True, mkGroupReporter mkEqErr) , ("skolem eq1", very_wrong, True, mkSkolReporter) @@ -671,6 +672,11 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics -- See also Note [Implementation of Unsatisfiable constraints], point (F). is_user_type_error item _ = containsUserTypeError (errorItemPred item) + is_implicit_lifting item _ = + case (errorItemOrigin item) of + ImplicitLiftOrigin {} -> True + _ -> False + is_homo_equality _ (EqPred _ ty1 ty2) = typeKind ty1 `tcEqType` typeKind ty2 is_homo_equality _ _ @@ -1082,7 +1088,7 @@ mkUserTypeErrorReporter :: Reporter mkUserTypeErrorReporter ctxt = mapM_ $ \item -> do { let err = important ctxt $ mkUserTypeError item ; maybeReportError ctxt (item :| []) err - ; addDeferredBinding err item } + ; addSolverDeferredBinding err item } mkUserTypeError :: ErrorItem -> TcSolverReportMsg mkUserTypeError item @@ -1095,6 +1101,21 @@ mkUserTypeError item where pty = errorItemPred item +mkImplicitLiftingReporter :: Reporter +mkImplicitLiftingReporter ctxt + = mapM_ $ \item -> do { let err = mkImplicitLiftingError item + ; msg <- mkErrorReport (ctLocEnv (errorItemCtLoc item)) err (Just ctxt) [] [] + ; reportDiagnostic msg + ; addDeferredBinding ctxt [] [] err item + } + + where + mkImplicitLiftingError :: ErrorItem -> TcRnMessage + mkImplicitLiftingError item = + case errorItemOrigin item of + ImplicitLiftOrigin bound used gre name -> TcRnBadlyLevelled (LevelCheckSplice name gre) bound used (Just item) (cec_defer_type_errors ctxt) + _ -> pprPanic "mkImplicitLiftingError" (ppr item) + mkGivenErrorReporter :: Reporter -- See Note [Given errors] mkGivenErrorReporter ctxt (item:|_) @@ -1192,7 +1213,7 @@ reportGroup mk_err ctxt items ; maybeReportError ctxt items err -- But see Note [Always warn with -fdefer-type-errors] ; traceTc "reportGroup" (ppr items) - ; mapM_ (addDeferredBinding err) items } + ; mapM_ (addSolverDeferredBinding err) items } -- Add deferred bindings for all -- Redundant if we are going to abort compilation, -- but that's hard to know for sure, and if we don't @@ -1225,15 +1246,23 @@ maybeReportError ctxt items@(item1:|_) (SolverReport { sr_important_msg = import msg <- mkErrorReport (ctLocEnv (errorItemCtLoc item1)) diag (Just ctxt) supp hints reportDiagnostic msg -addDeferredBinding :: SolverReport -> ErrorItem -> TcM () +addSolverDeferredBinding :: SolverReport -> ErrorItem -> TcM () +addSolverDeferredBinding err item = + let ctxt = reportContext . sr_important_msg $ err + supp = sr_supplementary err + hints = sr_hints err + important = sr_important_msg err + in addDeferredBinding ctxt supp hints (TcRnSolverReport important ErrorWithoutFlag) item + + +addDeferredBinding :: SolverReportErrCtxt -> [SupplementaryInfo] -> [GhcHint] -> TcRnMessage -> ErrorItem -> TcM () -- See Note [Deferring coercion errors to runtime] -addDeferredBinding err (EI { ei_evdest = Just dest - , ei_pred = item_ty - , ei_loc = loc }) +addDeferredBinding ctxt supp hints msg (EI { ei_evdest = Just dest + , ei_pred = item_ty + , ei_loc = loc }) -- if evdest is Just, then the constraint was from a wanted - | let ctxt = reportContext . sr_important_msg $ err - , deferringAnyBindings ctxt - = do { err_tm <- mkErrorTerm loc item_ty err + | deferringAnyBindings ctxt + = do { err_tm <- mkErrorTerm loc item_ty ctxt msg supp hints ; let ev_binds_var = cec_binds ctxt ; case dest of @@ -1244,15 +1273,24 @@ addDeferredBinding err (EI { ei_evdest = Just dest let co_var = coHoleCoVar hole ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var EvNonCanonical err_tm ; fillCoercionHole hole (mkCoVarCo co_var) } } -addDeferredBinding _ _ = return () -- Do not set any evidence for Given +addDeferredBinding _ _ _ _ _ = return () -- Do not set any evidence for Given + +mkSolverErrorTerm :: CtLoc -> Type -- of the error term + -> SolverReport -> TcM EvTerm +mkSolverErrorTerm ct_loc ty err + = mkErrorTerm ct_loc ty (reportContext . sr_important_msg $ err) + (TcRnSolverReport (sr_important_msg err) ErrorWithoutFlag) + (sr_supplementary err) + (sr_hints err) mkErrorTerm :: CtLoc -> Type -- of the error term - -> SolverReport -> TcM EvTerm -mkErrorTerm ct_loc ty (SolverReport { sr_important_msg = important, sr_supplementary = supp, sr_hints = hints }) + -> SolverReportErrCtxt -> TcRnMessage + -> [SupplementaryInfo] -> [GhcHint] -> TcM EvTerm +mkErrorTerm ct_loc ty ctxt msg supp hints = do { msg <- mkErrorReport (ctLocEnv ct_loc) - (TcRnSolverReport important ErrorWithoutFlag) - (Just $ reportContext important) + msg + (Just $ ctxt) supp hints -- This will be reported at runtime, so we always want "error:" in the report, never "warning:" @@ -1526,7 +1564,7 @@ maybeAddDeferredBindings hole report = do -- not for holes in partial type signatures -- cf. addDeferredBinding when (deferringAnyBindings ctxt) $ do - err_tm <- mkErrorTerm (hole_loc hole) ref_ty report + err_tm <- mkSolverErrorTerm (hole_loc hole) ref_ty report -- NB: ref_ty, not hole_ty. hole_ty might be rewritten. -- See Note [Holes in expressions] in GHC.Hs.Expr writeMutVar ref err_tm ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -105,6 +105,7 @@ import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Fixity (defaultFixity) +import GHC.Types.ThLevelIndex (pprThBindLevel) import GHC.Iface.Errors.Types import GHC.Iface.Errors.Ppr @@ -1517,23 +1518,8 @@ instance Diagnostic TcRnMessage where hsep [ text "Unknown type variable" <> plural errorVars , text "on the RHS of injectivity condition:" , interpp'SP errorVars ] - TcRnBadlyLevelled reason bind_lvls use_lvl - -> - mkSimpleDecorated $ - vcat $ - [ fsep [ text "Level error:", pprLevelCheckReason reason - , text "is bound at" <+> pprThBindLevel bind_lvls - , text "but used at level" <+> ppr use_lvl] - ] ++ - [ fsep [ text "Hint: quoting" <+> thBrackets (ppUnless (isValName n) "t") (ppr n) - , text "or an enclosing expression" - , text "would allow the quotation to be used at an earlier level" - ] - | LevelCheckSplice n _ <- [reason] - ] ++ - [ "From imports" <+> (ppr (gre_imp gre)) - | LevelCheckSplice _ (Just gre) <- [reason] - , not (isEmptyBag (gre_imp gre)) ] + TcRnBadlyLevelled reason bind_lvls use_lvl lift_attempt _reason + -> pprTcRnBadlyLevelled reason bind_lvls use_lvl lift_attempt TcRnBadlyLevelledType name bind_lvls use_lvl -> mkSimpleDecorated $ text "Badly levelled type:" <+> ppr name <+> @@ -2490,8 +2476,8 @@ instance Diagnostic TcRnMessage where -> ErrorWithoutFlag TcRnUnknownTyVarsOnRhsOfInjCond{} -> ErrorWithoutFlag - TcRnBadlyLevelled{} - -> ErrorWithoutFlag + TcRnBadlyLevelled _ _ _ _ reason + -> reason TcRnBadlyLevelledType{} -> WarningWithFlag Opt_WarnBadlyLevelledTypes TcRnTyThingUsedWrong{} @@ -3389,6 +3375,22 @@ instance Diagnostic TcRnMessage where diagnosticCode = constructorCode @GHC +pprTcRnBadlyLevelled :: LevelCheckReason -> Set.Set ThLevelIndex -> ThLevelIndex -> Maybe ErrorItem -> DecoratedSDoc +pprTcRnBadlyLevelled reason bind_lvls use_lvl lift_attempt = mkDecorated $ + [ fsep [ text "Level error:", pprLevelCheckReason reason + , text "is bound at" <+> pprThBindLevel bind_lvls + , text "but used at level" <+> ppr use_lvl] + ] ++ + [hang (text "Could not be resolved by implicit lifting due to the following error:") 2 + (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] + , not (isEmptyBag (gre_imp gre)) ] + where + ppr_imports :: Bag ImportSpec -> [SDoc] + ppr_imports = map ((bullet <+>) . ppr ) . bagToList note :: SDoc -> SDoc note note = "Note" <> colon <+> note <> dot @@ -4537,8 +4539,7 @@ pprMismatchMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extra) : pp_givens useful_givens) supplementary = case mb_extra of - Nothing - -> Left [] + Nothing -> Right empty Just (CND_Extra level ty1 ty2) -> mk_supplementary_ea_msg ctxt level ty1 ty2 orig ct_loc = errorItemCtLoc item @@ -7491,6 +7492,3 @@ pprErrCtxtMsg = \case text "in" <+> quotes (ppr req_uid) <> dot -------------------------------------------------------------------------------- - -pprThBindLevel :: Set.Set ThLevelIndex -> SDoc -pprThBindLevel levels_set = text "level" <> pluralSet levels_set <+> pprUnquotedSet levels_set \ No newline at end of file ===================================== compiler/GHC/Tc/Errors/Types.hs ===================================== @@ -3497,6 +3497,8 @@ data TcRnMessage where :: !LevelCheckReason -- ^ The binding -> !(Set.Set ThLevelIndex) -- ^ The binding levels -> !ThLevelIndex -- ^ The level at which the binding is used. + -> !(Maybe ErrorItem) -- ^ The attempt we made to implicitly lift the binding. + -> DiagnosticReason -- ^ Whether to defer this error or fail -> TcRnMessage {-| TcRnBadlyLevelledWarn is a warning that occurs when a TH type binding is ===================================== compiler/GHC/Tc/Gen/Splice.hs ===================================== @@ -54,6 +54,7 @@ import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType import GHC.Tc.Gen.Expr +import GHC.Tc.Gen.Head import GHC.Tc.Utils.Unify import GHC.Tc.Utils.Env import GHC.Tc.Types.Origin @@ -720,8 +721,8 @@ tcUntypedBracket rn_expr brack ps res_ty -- Match the expected type with the type of all the internal -- splices. They might have further constrained types and if they do -- we want to reflect that in the overall type of the bracket. - ; ps' <- case quoteWrapperTyVarTy <$> brack_info of - Just m_var -> mapM (tcPendingSplice m_var) ps + ; ps' <- case brack_info of + Just q -> mapM (tcPendingSplice q) ps Nothing -> assert (null ps) $ return [] -- Notice that we don't attempt to typecheck the body @@ -781,11 +782,11 @@ brackTy b = --------------- -- | Typechecking a pending splice from a untyped bracket -tcPendingSplice :: TcType -- Metavariable for the expected overall type of the +tcPendingSplice :: QuoteWrapper -- Metavariable for the expected overall type of the -- quotation. -> PendingRnSplice -> TcM PendingTcSplice -tcPendingSplice m_var (PendingRnSplice flavour splice_name expr) +tcPendingSplice (QuoteWrapper _ m_var) (PendingRnSplice flavour splice_name expr) -- See Note [Typechecking Overloaded Quotes] = do { meta_ty <- tcMetaTy meta_ty_name -- Expected type of splice, e.g. m Exp @@ -799,6 +800,26 @@ tcPendingSplice m_var (PendingRnSplice flavour splice_name expr) UntypedPatSplice -> patTyConName UntypedTypeSplice -> typeTyConName UntypedDeclSplice -> decsTyConName + -- Identifiers that are lifted implicitly, such as 'x' in + -- E.g. \x -> [| h x |] + -- We must behave as if the reference to x was + -- h $(lift x) + -- We use 'x' itself as the SplicePointName, used by + -- the desugarer to stitch it all back together. + -- If 'x' occurs many times we may get many identical + -- bindings of the same SplicePointName, but that doesn't + -- matter, although it's a mite untidy. +tcPendingSplice q (PendingImplicitLift bound used gre id_name) + = do { (id_expr, id_ty) <- tcInferId id_name + -- lift :: Quote m' => a -> m' Exp + ; lift <- setSrcSpan (getLocA id_name) $ + newMethodFromName (ImplicitLiftOrigin bound used gre (getName id_name)) + GHC.Builtin.Names.TH.liftName + [getRuntimeRep id_ty, id_ty] + ; let res = nlHsApp (mkLHsWrap (applyQuoteWrapper q) (noLocA lift)) (noLocA id_expr) + + ; return (PendingTcSplice (getName id_name) res) } + --------------- -- Takes a m and tau and returns the type m (TExp tau) ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -1652,7 +1652,7 @@ checkCrossLevelClsInst dflags reason bind_lvls use_lvl_idx is_local -- With ImplicitStagePersistence, using later than bound is fine | xopt LangExt.ImplicitStagePersistence dflags , any (use_lvl_idx >=) bind_lvls = return () - | otherwise = TcM.addErrTc (TcRnBadlyLevelled reason bind_lvls use_lvl_idx) + | otherwise = TcM.addErrTc (TcRnBadlyLevelled reason bind_lvls use_lvl_idx Nothing ErrorWithoutFlag) ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -80,11 +80,13 @@ import GHC.Utils.Monad import GHC.Utils.Misc( HasDebugCallStack ) import GHC.Types.Unique import GHC.Types.Unique.Supply +import GHC.Types.ThLevelIndex import Language.Haskell.Syntax.Basic (FieldLabelString(..)) import qualified Data.Kind as Hs import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Set as S {- ********************************************************************* * * @@ -647,6 +649,7 @@ data CtOrigin Type -- the instance-sig type Type -- the instantiated type of the method | AmbiguityCheckOrigin UserTypeCtxt + | ImplicitLiftOrigin (S.Set ThLevelIndex) ThLevelIndex (Maybe GlobalRdrElt) Name data NonLinearPatternReason = LazyPatternReason @@ -944,6 +947,7 @@ pprCtO (UsageEnvironmentOf x) = hsep [text "multiplicity of", quotes (ppr x)] pprCtO (OmittedFieldOrigin Nothing) = text "an omitted anonymous field" pprCtO (OmittedFieldOrigin (Just fl)) = hsep [text "omitted field" <+> quotes (ppr fl)] pprCtO BracketOrigin = text "a quotation bracket" +pprCtO (ImplicitLiftOrigin _ _ _ n) = text "an implicit lift of" <+> quotes (ppr n) -- These ones are handled by pprCtOrigin, but we nevertheless sometimes -- get here via callStackOriginFS, when doing ambiguity checks @@ -978,7 +982,6 @@ pprNonLinearPatternReason PatternSynonymReason = parens (text "pattern synonyms pprNonLinearPatternReason ViewPatternReason = parens (text "view patterns aren't linear") pprNonLinearPatternReason OtherPatternReason = empty - {- ********************************************************************* * * CallStacks and CtOrigin ===================================== compiler/GHC/Types/ThLevelIndex.hs ===================================== @@ -3,9 +3,10 @@ module GHC.Types.ThLevelIndex where import GHC.Prelude import GHC.Utils.Outputable import GHC.Types.Basic ( ImportLevel(..) ) - +import Data.Data (Data) +import qualified Data.Set as Set -- | The integer which represents the level -newtype ThLevelIndex = ThLevelIndex Int deriving (Eq, Ord) +newtype ThLevelIndex = ThLevelIndex Int deriving (Eq, Ord, Data) -- NB: see Note [Template Haskell levels] in GHC.Tc.Gen.Splice -- Incremented when going inside a bracket, -- decremented when going inside a splice @@ -32,4 +33,7 @@ quoteLevelIndex = incThLevelIndex topLevelIndex thLevelIndexFromImportLevel :: ImportLevel -> ThLevelIndex thLevelIndexFromImportLevel NormalLevel = topLevelIndex thLevelIndexFromImportLevel SpliceLevel = spliceLevelIndex -thLevelIndexFromImportLevel QuoteLevel = quoteLevelIndex \ No newline at end of file +thLevelIndexFromImportLevel QuoteLevel = quoteLevelIndex + +pprThBindLevel :: Set.Set ThLevelIndex -> SDoc +pprThBindLevel levels_set = text "level" <> pluralSet levels_set <+> pprUnquotedSet levels_set \ No newline at end of file ===================================== testsuite/tests/quotes/LiftErrMsg.hs ===================================== @@ -0,0 +1,27 @@ +{-# LANGUAGE NoImplicitStagePersistence #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +module LiftErrMsg where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +data B = B + +local_b :: [B] +local_b = [B] + +test :: Q Exp +test = [| id |] + +test2 :: Q Exp +test2 = [| (id, id) |] + +test3 :: Q Exp +test3 = [| local_b |] + +test4 :: a -> Q Exp +test4 x = [| x |] + +test5 :: Lift a => a -> Q Exp +test5 x = [| x |] + ===================================== testsuite/tests/quotes/LiftErrMsg.stderr ===================================== @@ -0,0 +1,38 @@ +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 (forall a. a -> a)’ + • Available from the imports: + • imported from ‘Prelude’ at LiftErrMsg.hs:3:8-17 + • In the expression: + [| id |] + pending(rn) [implicit lift: id] + In an equation for ‘test’: + test + = [| id |] + pending(rn) [implicit lift: id] + +LiftErrMsg.hs:20:12: error: [GHC-28914] + • Level error: ‘local_b’ 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 B’ + • In the expression: + [| local_b |] + pending(rn) [implicit lift: local_b] + In an equation for ‘test3’: + test3 + = [| local_b |] + pending(rn) [implicit lift: local_b] + +LiftErrMsg.hs:23:14: error: [GHC-28914] + • Level error: ‘x’ 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’ + • In the expression: + [| x |] + pending(rn) [implicit lift: x] + In an equation for ‘test4’: + test4 x + = [| x |] + pending(rn) [implicit lift: x] + ===================================== testsuite/tests/quotes/LiftErrMsgDefer.hs ===================================== @@ -0,0 +1,26 @@ +{-# LANGUAGE NoImplicitStagePersistence #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +module Main where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +data B = B + +local_b :: [B] +local_b = [B] + +test1 :: Q Exp +test1 = [| id |] + +test2 :: Q Exp +test2 = [| (id, id) |] + +test3 :: Q Exp +test3 = [| local_b |] + +main = do + runQ test1 + runQ test2 + runQ test3 + return () ===================================== testsuite/tests/quotes/LiftErrMsgDefer.stderr ===================================== @@ -0,0 +1,22 @@ +LiftErrMsgDefer: Uncaught exception ghc-internal:GHC.Internal.Control.Exception.Base.TypeError: + +LiftErrMsgDefer.hs:14:12: warning: [GHC-28914] [-Wdeferred-type-errors (in -Wdefault)] + • 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 (forall a. a -> a)’ + • Available from the imports: + • imported from ‘Prelude’ at LiftErrMsgDefer.hs:3:8-11 + • In the expression: + [| id |] + pending(rn) [implicit lift: id] + In an equation for ‘test1’: + test1 + = [| id |] + pending(rn) [implicit lift: id] +(deferred type error) + +HasCallStack backtrace: + collectBacktraces, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:169:13 in ghc-internal:GHC.Internal.Exception + toExceptionWithBacktrace, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:89:42 in ghc-internal:GHC.Internal.Exception + throw, called at libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs:435:30 in ghc-internal:GHC.Internal.Control.Exception.Base + ===================================== testsuite/tests/quotes/all.T ===================================== @@ -43,3 +43,5 @@ test('T20893', normal, compile_and_run, ['']) test('T21619', normal, compile, ['']) test('T20472_quotes', normal, compile, ['']) test('T24750', normal, compile_and_run, ['']) +test('LiftErrMsg', normal, compile_fail, ['']) +test('LiftErrMsgDefer', [exit_code(1)], compile_and_run, ['-fdefer-type-errors']) ===================================== testsuite/tests/th/TH_Lift.stderr ===================================== @@ -1,161 +1,161 @@ TH_Lift.hs:18:6-39: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (5 :: Integer) ======> 5 TH_Lift.hs:21:6-35: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (5 :: Int) ======> 5 TH_Lift.hs:24:7-37: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (5 :: Int8) ======> 5 TH_Lift.hs:27:7-38: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (5 :: Int16) ======> 5 TH_Lift.hs:30:7-38: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (5 :: Int32) ======> 5 TH_Lift.hs:33:7-38: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (5 :: Int64) ======> 5 TH_Lift.hs:36:6-36: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (5 :: Word) ======> 5 TH_Lift.hs:39:6-37: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (5 :: Word8) ======> 5 TH_Lift.hs:42:6-38: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (5 :: Word16) ======> 5 TH_Lift.hs:45:6-38: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (5 :: Word32) ======> 5 TH_Lift.hs:48:6-38: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (5 :: Word64) ======> 5 TH_Lift.hs:51:7-40: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (5 :: Natural) ======> 5 TH_Lift.hs:54:6-44: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (5 % 3 :: Rational) ======> 1.6666666666666667 TH_Lift.hs:57:7-39: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (pi :: Float) ======> 3.1415927410125732 TH_Lift.hs:60:7-40: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (pi :: Double) ======> 3.141592653589793 TH_Lift.hs:63:6-28: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) 'x' ======> 'x' TH_Lift.hs:66:6-29: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) True ======> True TH_Lift.hs:69:6-35: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (Just 'x') ======> Just 'x' TH_Lift.hs:72:6-58: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (Right False :: Either Char Bool) ======> Right False TH_Lift.hs:75:6-29: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) "hi!" ======> "hi!" TH_Lift.hs:78:6-27: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) () ======> () TH_Lift.hs:81:6-46: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) (True, 'x', 4 :: Int) ======> (,,) True 'x' 4 TH_Lift.hs:84:6-41: Splicing expression (\ x -> [| x |] - pending(rn) [<x, lift x>]) + pending(rn) [implicit lift: x]) ('a' :| "bcde") ======> (:|) 'a' "bcde" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fe034312f9c4715836cd2b17985b5d35... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fe034312f9c4715836cd2b17985b5d35... You're receiving this email because of your account on gitlab.haskell.org.