Apoorv Ingle pushed to branch wip/ani/kill-SrcCodeOrigin at Glasgow Haskell Compiler / GHC Commits: eac62087 by Apoorv Ingle at 2026-02-13T10:28:29-06:00 wip - - - - - 23 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Do.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/Tc/Types/LclEnv.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Tc/Validity.hs - compiler/GHC/Unit/State.hs-boot - compiler/GHC/Utils/Logger.hs Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -686,7 +686,7 @@ mkExpandedStmt -> HsDoFlavour -- ^ source statements do flavour -> HsExpr GhcRn -- ^ expanded expression -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn' -mkExpandedStmt oStmt flav eExpr = XExpr (ExpandedThingRn { xrn_orig = StmtErrCtxt (HsDoStmt flav) oStmt +mkExpandedStmt oStmt flav eExpr = XExpr (ExpandedThingRn { xrn_orig = DoStmtErrCtxt (HsDoStmt flav) oStmt , xrn_expanded = eExpr }) data XXExprGhcTc ===================================== compiler/GHC/Hs/Instances.hs ===================================== @@ -620,13 +620,48 @@ deriving instance Eq (IE GhcTc) -- --------------------------------------------------------------------- -deriving instance Data ErrCtxtMsg -deriving instance Data XXExprGhcRn +-- deriving instance Data ErrCtxtMsg +-- deriving instance Data XXExprGhcRn +con_ExpandedThingRn = mkConstr xXExprGhcRn_T "ExpandedThingRn" [] Prefix +con_HsRecSelRn = mkConstr xXExprGhcRn_T "HsRecSelRn" [] Prefix +xXExprGhcRn_T = mkDataType "GHC.Hs.Expr.XXExprGhcRn" [] + +instance Data XXExprGhcRn where + toConstr (ExpandedThingRn{}) = con_ExpandedThingRn + toConstr (HsRecSelRn{}) = con_HsRecSelRn + + dataTypeOf _ = xXExprGhcRn_T + + gunfold k z c = error "no gunfold for XXExprGhcRn" + gfoldl k z c = error "no gfoldl for XXExprGhcRn" + deriving instance Data a => Data (WithUserRdr a) -- --------------------------------------------------------------------- -deriving instance Data XXExprGhcTc +-- deriving instance Data XXExprGhcTc +con_ExpandedThingTc = mkConstr xXExprGhcTc_T "ExpandedThingTc" [] Prefix +con_WrapExpr = mkConstr xXExprGhcTc_T "WrapExpr" [] Prefix +con_ConLikeTc = mkConstr xXExprGhcTc_T "ConLikeTc" [] Prefix +con_HsTick = mkConstr xXExprGhcTc_T "HsTick" [] Prefix +con_HsBinTick = mkConstr xXExprGhcTc_T "HsBinTick" [] Prefix +con_HsRecSelTc = mkConstr xXExprGhcTc_T "HsRecSelTc" [] Prefix +xXExprGhcTc_T = mkDataType "GHC.Hs.Expr.XXExprGhcTc" [] + +instance Data XXExprGhcTc where + toConstr (ExpandedThingTc{}) = con_ExpandedThingTc + toConstr (WrapExpr{}) = con_WrapExpr + toConstr (ConLikeTc{}) = con_ConLikeTc + toConstr (HsTick{}) = con_HsTick + toConstr (HsBinTick{}) = con_HsBinTick + toConstr (HsRecSelTc{}) = con_HsRecSelTc + + dataTypeOf _ = xXExprGhcTc_T + + + gunfold _ _ _ = error "no gunfold for XXExprGhcTc" + gfoldl _ _ _ = error "no gfoldl for XXExprGhcTc" + deriving instance Data XXPatGhcTc -- --------------------------------------------------------------------- ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -47,6 +47,7 @@ import GHC.Types.CostCentre import GHC.Types.CostCentre.State import GHC.Types.Tickish import GHC.Types.ProfAuto +import GHC.Tc.Types.ErrCtxt import Control.Monad import Data.List (isSuffixOf, intersperse) @@ -414,7 +415,7 @@ addTickLHsExpr e@(L pos e0) = do d <- getDensity case d of TickForBreakPoints | isGoodBreakExpr e0 -> tick_it - TickForCoverage | XExpr (ExpandedThingTc OrigStmt{} _) <- e0 -- expansion ticks are handled separately + TickForCoverage | XExpr (ExpandedThingTc StmtErrCtxt{} _) <- e0 -- expansion ticks are handled separately -> dont_tick_it | otherwise -> tick_it TickCallSites | isCallSite e0 -> tick_it @@ -483,7 +484,7 @@ addTickLHsExprNever (L pos e0) = do -- General heuristic: expressions which are calls (do not denote -- values) are good break points. isGoodBreakExpr :: HsExpr GhcTc -> Bool -isGoodBreakExpr (XExpr (ExpandedThingTc (OrigStmt{}) _)) = False +isGoodBreakExpr (XExpr (ExpandedThingTc (StmtErrCtxt{}) _)) = False isGoodBreakExpr e = isCallSite e isCallSite :: HsExpr GhcTc -> Bool @@ -658,11 +659,11 @@ addTickHsExpr (HsDo srcloc cxt (L l stmts)) ListComp -> Just $ BinBox QualBinBox _ -> Nothing -addTickHsExpanded :: SrcCodeOrigin -> HsExpr GhcTc -> TM (HsExpr GhcTc) +addTickHsExpanded :: ErrCtxtMsg -> HsExpr GhcTc -> TM (HsExpr GhcTc) addTickHsExpanded o e = liftM (XExpr . ExpandedThingTc o) $ case o of -- We always want statements to get a tick, so we can step over each one. -- To avoid duplicates we blacklist SrcSpans we already inserted here. - OrigStmt (L pos _) _ -> do_tick_black pos + DoStmtErrCtxt _ (L pos _) -> do_tick_black pos _ -> skip where skip = addTickHsExpr e ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -39,6 +39,7 @@ import GHC.Core.TyCon ( TyCon, tyConClass_maybe ) import GHC.Core.InstEnv import GHC.Core.Predicate ( isEvId ) import GHC.Tc.Types +import GHC.Tc.Types.ErrCtxt import GHC.Tc.Types.Evidence import GHC.Types.Var ( Id, Var, EvId, varName, varType, varUnique ) import GHC.Types.Var.Env @@ -755,7 +756,7 @@ instance HiePass p => HasType (LocatedA (HsExpr (GhcPass p))) where ExprWithTySig _ e _ -> computeLType e HsPragE _ _ e -> computeLType e XExpr (ExpandedThingTc thing e) - | OrigExpr (HsGetField{}) <- thing -- for record-dot-syntax + | ExprCtxt (HsGetField{}) <- thing -- for record-dot-syntax -> Just (hsExprType e) | otherwise -> computeType e XExpr (HsTick _ e) -> computeLType e ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -83,7 +83,6 @@ import qualified GHC.Data.Strict as Strict import Language.Haskell.Syntax.Basic (FieldLabelString(..)) import Language.Haskell.Syntax (HsExpr (RecordUpd, HsGetField, HsProjection)) -import GHC.Hs.Expr (SrcCodeOrigin(..)) import Control.Monad ( when, foldM, forM_ ) import Data.Bifunctor ( bimap ) ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -68,11 +68,11 @@ import GHC.Core.FVs( orphNamesOfTypes ) import GHC.CoreToIface import GHC.Driver.Flags --- import GHC.Driver.Backend +import GHC.Driver.Backend import GHC.Hs hiding (HoleError) import GHC.Hs.Decls.Overlap --- import GHC.Tc.Errors.Types +import GHC.Tc.Errors.Types import GHC.Tc.Errors.Types.PromotionErr (pprTermLevelUseCtxt) import GHC.Tc.Errors.Hole.FitTypes import GHC.Tc.Types.BasicTypes @@ -109,7 +109,7 @@ import GHC.Iface.Errors.Types import GHC.Iface.Errors.Ppr import GHC.Iface.Syntax --- import GHC.Unit.State +import GHC.Unit.State import GHC.Unit.Module import GHC.Data.Bag @@ -7881,6 +7881,18 @@ pprErrCtxtMsg = \case -> hang (text "In a stmt of" <+> pprAStmtContext ctxt <> colon) 2 (ppr_stmt stmt) + DoStmtErrCtxt ctxt stmt + -- For [ e | .. ], do not mutter about "stmts" + | LastStmt _ e _ _ <- (unLoc stmt) + , isComprehensionContext ctxt + -> hang (text "In the expression:") 2 (ppr e) + | otherwise + -> hang (text "In a stmt of" <+> pprAStmtContext ctxt <> colon) + 2 (ppr_stmt (unLoc stmt)) + + StmtErrCtxtPat _ _ pat -> + hang (text "In the pattern:") 2 (ppr pat) + DerivInstCtxt pred -> text "When deriving the instance for" <+> parens (ppr pred) StandaloneDerivCtxt ty -> ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -973,8 +973,8 @@ addArgCtxt arg_no (app_head, app_head_lspan) (L arg_loc arg) thing_inside where addNthFunArgErrCtxt :: HsExpr GhcRn -> HsExpr GhcRn -> Int -> TcM a -> TcM a addNthFunArgErrCtxt app_head arg arg_no thing_inside - | XExpr (ExpandedThingRn o _) <- arg - = addExpansionErrCtxt o (FunAppCtxt (FunAppCtxtExpr app_head arg) arg_no) $ + | XExpr (ExpandedThingRn _ _) <- arg + = addExpansionErrCtxt (FunAppCtxt (FunAppCtxtExpr app_head arg) arg_no) $ thing_inside | otherwise = addErrCtxt (FunAppCtxt (FunAppCtxtExpr app_head arg) arg_no) $ ===================================== compiler/GHC/Tc/Gen/Bind.hs ===================================== @@ -66,7 +66,7 @@ import GHC.Types.SourceText import GHC.Types.Id import GHC.Types.Var as Var import GHC.Types.Var.Set -import GHC.Types.Var.Env( TidyEnv, TyVarEnv, mkVarEnv, lookupVarEnv ) +import GHC.Types.Var.Env( TyVarEnv, mkVarEnv, lookupVarEnv ) import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env @@ -970,7 +970,7 @@ mkInferredPolyId residual insoluble qtvs inferred_theta poly_name mb_sig_inst mo , text "insoluble" <+> ppr insoluble ]) ; unless insoluble $ - addErrCtxtM (mk_inf_msg poly_name inferred_poly_ty) $ + addErrCtxtM (InferredTypeCtxt poly_name inferred_poly_ty) $ do { checkEscapingKind inferred_poly_ty -- See Note [Inferred type with escaping kind] ; checkValidType (InfSigCtxt poly_name) inferred_poly_ty } @@ -1120,11 +1120,6 @@ chooseInferredQuantifiers residual inferred_theta tau_tvs qtvs chooseInferredQuantifiers _ _ _ _ (Just sig) = pprPanic "chooseInferredQuantifiers" (ppr sig) -mk_inf_msg :: Name -> TcType -> TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg) -mk_inf_msg poly_name poly_ty tidy_env - = do { (tidy_env1, poly_ty) <- zonkTidyTcType tidy_env poly_ty - ; return (tidy_env1, InferredTypeCtxt poly_name poly_ty) } - -- | Warn the user about polymorphic local binders that lack type signatures. localSigWarn :: Id -> Maybe TcIdSigInst -> TcM () localSigWarn id mb_sig @@ -1909,4 +1904,3 @@ NoGen is good when we have call sites, but not at top level, where the function may be exported. And it's easier to grok "MonoLocalBinds" as applying to, well, local bindings. -} - ===================================== compiler/GHC/Tc/Gen/Do.hs ===================================== @@ -20,7 +20,7 @@ import GHC.Rename.Env ( irrefutableConLikeRn ) import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcMType - +import GHC.Tc.Types.ErrCtxt import GHC.Hs import GHC.Utils.Outputable @@ -213,7 +213,7 @@ mk_fail_block doFlav pat stmt e (Just (SyntaxExprRn fail_op)) = fail_op_expr :: DynFlags -> LPat GhcRn -> HsExpr GhcRn -> LHsExpr GhcRn fail_op_expr dflags pat@(L pat_lspan _) fail_op - = L pat_lspan $ mkExpandedPatRn (unLoc pat) stmt $ genHsApp fail_op (mk_fail_msg_expr dflags pat) + = L pat_lspan $ mkExpandedPatRn doFlav (unLoc pat) stmt $ genHsApp fail_op (mk_fail_msg_expr dflags pat) mk_fail_msg_expr :: DynFlags -> LPat GhcRn -> LHsExpr GhcRn mk_fail_msg_expr dflags pat @@ -481,7 +481,7 @@ It stores the original statement (with location) and the expanded expression -} -mkExpandedPatRn :: Pat GhcRn -> ExprLStmt GhcRn -> HsExpr GhcRn -> HsExpr GhcRn -mkExpandedPatRn oflav pat stmt e = XExpr $ ExpandedThingRn +mkExpandedPatRn :: HsDoFlavour -> Pat GhcRn -> ExprLStmt GhcRn -> HsExpr GhcRn -> HsExpr GhcRn +mkExpandedPatRn flav pat stmt e = XExpr $ ExpandedThingRn { xrn_orig = StmtErrCtxtPat (HsDoStmt flav) stmt pat - , xrn_expand = e} + , xrn_expanded = e} ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -1006,7 +1006,8 @@ addFunResCtxt :: HsExpr GhcTc -> [HsExprArg p] addFunResCtxt fun args fun_res_ty env_ty thing_inside = do { env_tv <- newFlexiTyVarTy liftedTypeKind ; dumping <- doptM Opt_D_dump_tc_trace - ; addLandmarkErrCtxtM (\env -> (env, ) <$> mk_msg dumping env_tv) thing_inside } + ; msg <- mk_msg dumping env_tv + ; addLandmarkErrCtxtM msg thing_inside } -- NB: use a landmark error context, so that an empty context -- doesn't suppress some more useful context where @@ -1014,13 +1015,12 @@ addFunResCtxt fun args fun_res_ty env_ty thing_inside = do { mb_env_ty <- readExpType_maybe env_ty -- by the time the message is rendered, the ExpType -- will be filled in (except if we're debugging) - ; fun_res' <- zonkTcType fun_res_ty ; env' <- case mb_env_ty of - Just env_ty -> zonkTcType env_ty + Just env_ty -> return env_ty Nothing -> do { massert dumping; return env_tv } ; let -- See Note [Splitting nested sigma types in mismatched -- function types] - (_, _, fun_tau) = tcSplitNestedSigmaTys fun_res' + (_, _, fun_tau) = tcSplitNestedSigmaTys fun_res_ty (_, _, env_tau) = tcSplitNestedSigmaTys env' -- env_ty is an ExpRhoTy, but with simple subsumption it -- is not deeply skolemised, so still use tcSplitNestedSigmaTys ===================================== compiler/GHC/Tc/Gen/HsType.hs ===================================== @@ -353,7 +353,7 @@ funsSigCtxt :: [LocatedN Name] -> UserTypeCtxt funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 NoRRC funsSigCtxt [] = panic "funSigCtxt" -addSigCtxt :: UserTypeCtxt -> UserSigType GhcRn -> TcM a -> TcM a +addSigCtxt :: UserTypeCtxt -> UserSigType -> TcM a -> TcM a addSigCtxt ctxt hs_ty thing_inside = setSrcSpan l $ addErrCtxt (UserSigCtxt ctxt hs_ty) $ ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -487,7 +487,7 @@ tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside | otherwise = do { (stmt', (stmts', thing)) <- setSrcSpanA loc $ - addErrCtxt (StmtErrCtxt ctxt stmt) $ + addErrCtxt (StmtErrCtxt ctxt (L loc stmt)) $ stmt_chk ctxt stmt res_ty $ \ res_ty' -> popErrCtxt $ tcStmtsAndThen ctxt stmt_chk stmts res_ty' $ ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -39,7 +39,6 @@ import GHC.Core.Multiplicity import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcMType -import GHC.Tc.Zonk.TcType import GHC.Core.TyCo.Ppr ( pprTyVars ) import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Unify @@ -1021,7 +1020,8 @@ tcPatSig in_pat_bind sig res_ty ; case NE.nonEmpty sig_tvs of Nothing -> do { -- Just do the subsumption check and return - wrap <- addErrCtxtM (mk_msg sig_ty) $ + msg <- mk_msg res_ty sig_ty + ; wrap <- addErrCtxtM msg $ tcSubTypePat PatSigOrigin PatSigCtxt res_ty sig_ty ; return (sig_ty, [], sig_wcs, wrap) } @@ -1035,18 +1035,17 @@ tcPatSig in_pat_bind sig res_ty (addErr (TcRnCannotBindScopedTyVarInPatSig sig_tvs_ne)) -- Now do a subsumption check of the pattern signature against res_ty - wrap <- addErrCtxtM (mk_msg sig_ty) $ + msg <- mk_msg res_ty sig_ty + wrap <- addErrCtxtM msg $ tcSubTypePat PatSigOrigin PatSigCtxt res_ty sig_ty -- Phew! return (sig_ty, sig_tvs, sig_wcs, wrap) } where - mk_msg sig_ty tidy_env - = do { (tidy_env, sig_ty) <- zonkTidyTcType tidy_env sig_ty - ; res_ty <- readExpType res_ty -- should be filled in by now - ; (tidy_env, res_ty) <- zonkTidyTcType tidy_env res_ty - ; return (tidy_env, PatSigErrCtxt sig_ty res_ty) } + mk_msg res_ty sig_ty + = do { res_ty <- readExpType res_ty -- should be filled in by now + ; return $ PatSigErrCtxt sig_ty res_ty } {- ********************************************************************* * * ===================================== compiler/GHC/Tc/TyCl/Instance.hs ===================================== @@ -2108,7 +2108,7 @@ tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind -- The instance-sig is the focus here; the class-meth-sig -- is fixed (#18036) ; let orig = InstanceSigOrigin sel_name sig_ty local_meth_ty - ; hs_wrap <- addErrCtxtM (methSigCtxt sel_name sig_ty local_meth_ty) $ + ; hs_wrap <- addErrCtxtM (MethSigCtxt sel_name sig_ty meth_ty) $ tcSubTypeSigma orig ctxt sig_ty local_meth_ty ; return (sig_ty, hs_wrap) } @@ -2176,11 +2176,6 @@ mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id poly_meth_ty = mkSpecSigmaTy tyvars theta local_meth_ty theta = map idType dfun_ev_vars -methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg) -methSigCtxt sel_name sig_ty meth_ty env0 - = do { (env1, sig_ty) <- zonkTidyTcType env0 sig_ty - ; (env2, meth_ty) <- zonkTidyTcType env1 meth_ty - ; return (env2, MethSigCtxt sel_name sig_ty meth_ty) } {- Note [Instance method signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Tc/Types/ErrCtxt.hs ===================================== @@ -175,10 +175,16 @@ data ErrCtxtMsg -- | Warning emitted when inferring use of visible dependent quantification. | VDQWarningCtxt !TcTyCon - -- | In a statement. - | StmtErrCtxt !HsStmtContextRn !(ExprLStmt GhcRn) + -- | In a statement + | forall body. + ( Anno (StmtLR GhcRn GhcRn body) ~ SrcSpanAnnA + , Outputable body + ) => StmtErrCtxt !HsStmtContextRn !(StmtLR GhcRn GhcRn body) - -- | In patten of the statement. (c.f. MonadFailErrors) + -- | In a do statement. + | DoStmtErrCtxt !HsStmtContextRn !(ExprLStmt GhcRn) + + -- | In patten of the do statement. (c.f. MonadFailErrors) | StmtErrCtxtPat !HsStmtContextRn !(ExprLStmt GhcRn) (Pat GhcRn) -- | In an rebindable syntax expression. ===================================== compiler/GHC/Tc/Types/LclEnv.hs ===================================== @@ -36,7 +36,6 @@ module GHC.Tc.Types.LclEnv ( import GHC.Prelude -import GHC.Hs ( SrcCodeOrigin (..) ) import GHC.Tc.Utils.TcType ( TcLevel ) import GHC.Tc.Errors.Types ( TcRnMessage ) @@ -120,8 +119,8 @@ push the new expression error message on top of the stack. cf. `LclEnv.setLclCtx type ErrCtxtStack = [ErrCtxt] -- | Get the original source code -get_src_code_origin :: ErrCtxtStack -> Maybe SrcCodeOrigin -get_src_code_origin (MkErrCtxt (ExpansionCodeCtxt origSrcCode) _ : _) = Just origSrcCode +get_src_code_origin :: ErrCtxtStack -> Maybe ErrCtxtMsg +get_src_code_origin (MkErrCtxt ExpansionCodeCtxt e : _) = Just e -- we are in generated code, due to the expansion of the original syntax origSrcCode get_src_code_origin _ = Nothing -- we are in user code, so blame the expression in hand @@ -203,7 +202,7 @@ setLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_err_ctxt = ctxt }) addLclEnvErrCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv addLclEnvErrCtxt ec = setLclEnvSrcCodeOrigin ec -getLclEnvSrcCodeOrigin :: TcLclEnv -> Maybe SrcCodeOrigin +getLclEnvSrcCodeOrigin :: TcLclEnv -> Maybe ErrCtxtMsg getLclEnvSrcCodeOrigin = get_src_code_origin . tcl_err_ctxt . tcl_lcl_ctxt setLclEnvSrcCodeOrigin :: ErrCtxt -> TcLclEnv -> TcLclEnv @@ -212,18 +211,18 @@ setLclEnvSrcCodeOrigin ec = modifyLclCtxt (setLclCtxtSrcCodeOrigin ec) -- See Note [ErrCtxtStack Manipulation] setLclCtxtSrcCodeOrigin :: ErrCtxt -> TcLclCtxt -> TcLclCtxt setLclCtxtSrcCodeOrigin ec lclCtxt - | ecs@(MkErrCtxt (ExpansionCodeCtxt{}) _ : _) <- tcl_err_ctxt lclCtxt - , MkErrCtxt (ExpansionCodeCtxt ExprCtxt{}) _ <- ec + | ecs@(MkErrCtxt ExpansionCodeCtxt _ : _) <- tcl_err_ctxt lclCtxt + , MkErrCtxt ExpansionCodeCtxt ExprCtxt{} <- ec = lclCtxt { tcl_err_ctxt = ec : ecs } - | MkErrCtxt (ExpansionCodeCtxt{}) _ : ecs <- tcl_err_ctxt lclCtxt - , MkErrCtxt (ExpansionCodeCtxt{}) _ <- ec + | MkErrCtxt ExpansionCodeCtxt _ : ecs <- tcl_err_ctxt lclCtxt + , MkErrCtxt ExpansionCodeCtxt _ <- ec = lclCtxt { tcl_err_ctxt = ec : ecs } | otherwise = lclCtxt { tcl_err_ctxt = ec : tcl_err_ctxt lclCtxt } lclCtxtInGeneratedCode :: TcLclCtxt -> Bool lclCtxtInGeneratedCode lclCtxt - | (MkErrCtxt (ExpansionCodeCtxt _) _ : _) <- tcl_err_ctxt lclCtxt + | (MkErrCtxt ExpansionCodeCtxt _ : _) <- tcl_err_ctxt lclCtxt = True | otherwise = False ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -51,6 +51,7 @@ module GHC.Tc.Types.Origin ( import GHC.Prelude import GHC.Tc.Utils.TcType +import GHC.Tc.Types.ErrCtxt import GHC.Hs @@ -836,7 +837,7 @@ exprCtOrigin e@(HsGetField{}) = ExpansionOrigin (ExprCtxt e) exprCtOrigin (XExpr (ExpandedThingRn o _)) = ExpansionOrigin o exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel $ L (getLoc $ foLabel f) (foExt f) -srcCodeOriginCtOrigin :: HsExpr GhcRn -> Maybe SrcCodeOrigin -> CtOrigin +srcCodeOriginCtOrigin :: HsExpr GhcRn -> Maybe ErrCtxtMsg -> CtOrigin srcCodeOriginCtOrigin e Nothing = exprCtOrigin e srcCodeOriginCtOrigin _ (Just o) = ExpansionOrigin o @@ -874,7 +875,7 @@ pprCtOrigin (ExpansionOrigin o) what = case o of StmtErrCtxt{} -> text "a do statement" - StmtErrCtxtPat _ p -> + StmtErrCtxtPat _ _ p -> text "a do statement" $$ text "with the failable pattern" <+> quotes (ppr p) ExprCtxt (HsGetField _ _ (L _ f)) -> @@ -887,6 +888,7 @@ pprCtOrigin (ExpansionOrigin o) ExprCtxt (HsProjection _ p) -> text "the record selector" <+> quotes (ppr ((FieldLabelStrings $ fmap noLocA p))) ExprCtxt e -> text "the expression" <+> (ppr e) + _ -> text "shouldn't happen ExpansionOrigin pprCtOrigin" pprCtOrigin (GivenSCOrigin sk d blk) = vcat [ ctoHerald <+> pprSkolInfo sk @@ -1112,6 +1114,7 @@ ppr_br (ExpansionOrigin (ExprCtxt (HsIf{}))) = text "an if-then-else expression" ppr_br (ExpansionOrigin (ExprCtxt e)) = text "an expression" <+> ppr e ppr_br (ExpansionOrigin (StmtErrCtxt{})) = text "a do statement" ppr_br (ExpansionOrigin (StmtErrCtxtPat{})) = text "a do statement" +ppr_br (ExpansionOrigin{}) = text "shouldn't happen ExpansionOrigin ppr_br" ppr_br (ExpectedTySyntax o _) = ppr_br o ppr_br (ExpectedFunTySyntaxOp{}) = text "a rebindable syntax operator" ppr_br (ExpectedFunTyViewPat{}) = text "a view pattern" ===================================== compiler/GHC/Tc/Utils/Instantiate.hs ===================================== @@ -67,7 +67,6 @@ import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType import GHC.Tc.Errors.Types -import GHC.Tc.Zonk.Monad ( ZonkM ) import GHC.Rename.Utils( mkRnSyntaxExpr ) @@ -855,7 +854,7 @@ tcSyntaxName orig ty (std_nm, user_nm_expr) = do -- case of locally-polymorphic methods. span <- getSrcSpanM - addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1 span) $ do + addErrCtxtM (SyntaxNameCtxt user_nm_expr orig sigma1 span) $ do -- Check that the user-supplied thing has the -- same type as the standard one. @@ -864,11 +863,6 @@ tcSyntaxName orig ty (std_nm, user_nm_expr) = do hasFixedRuntimeRepRes std_nm user_nm_expr sigma1 return (std_nm, unLoc expr) -syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> SrcSpan - -> TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg) -syntaxNameCtxt name orig ty loc tidy_env = - return (tidy_env, SyntaxNameCtxt name orig (tidyType tidy_env ty) loc) - {- ************************************************************************ * * ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -1091,12 +1091,8 @@ setSrcSpan (RealSrcSpan loc _) thing_inside setSrcSpan _ thing_inside = thing_inside -getSrcCodeOrigin :: TcRn (Maybe SrcCodeOrigin) -getSrcCodeOrigin = - do inGenCode <- inGeneratedCode - if inGenCode - then getLclEnvSrcCodeOrigin <$> getLclEnv - else return Nothing +getSrcCodeOrigin :: TcRn (Maybe ErrCtxtMsg) +getSrcCodeOrigin = getLclEnvSrcCodeOrigin <$> getLclEnv setSrcSpanA :: EpAnn ann -> TcRn a -> TcRn a setSrcSpanA l = setSrcSpan (locA l) @@ -1369,21 +1365,21 @@ setErrCtxt ctxt = updLclEnv (setLclEnvErrCtxt ctxt) -- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr addErrCtxt :: ErrCtxtMsg -> TcM a -> TcM a {-# INLINE addErrCtxt #-} -- Note [Inlining addErrCtxt] -addErrCtxt msg = addErrCtxtM (\env -> return (env, msg)) +addErrCtxt msg = addErrCtxtM msg -- See Note [ErrCtxtStack Manipulation] addExpansionErrCtxt :: ErrCtxtMsg -> TcM a -> TcM a {-# INLINE addExpansionErrCtxt #-} -- Note [Inlining addErrCtxt] -addExpansionErrCtxt msg = addExpansionErrCtxtM (\env -> return (env, msg)) +addExpansionErrCtxt msg = addExpansionErrCtxtM msg -- | Add a message to the error context. This message may do tidying. -- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr -addErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) -> TcM a -> TcM a +addErrCtxtM :: ErrCtxtMsg -> TcM a -> TcM a {-# INLINE addErrCtxtM #-} -- Note [Inlining addErrCtxt] addErrCtxtM ctxt = pushCtxt (MkErrCtxt VanillaUserSrcCode ctxt) -- See Note [ErrCtxtStack Manipulation] -addExpansionErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) -> TcM a -> TcM a +addExpansionErrCtxtM :: ErrCtxtMsg -> TcM a -> TcM a {-# INLINE addExpansionErrCtxtM #-} -- Note [Inlining addErrCtxt] addExpansionErrCtxtM ctxt = pushCtxt (MkErrCtxt ExpansionCodeCtxt ctxt) @@ -1393,11 +1389,11 @@ addExpansionErrCtxtM ctxt = pushCtxt (MkErrCtxt ExpansionCodeCtxt ctxt) -- reported. addLandmarkErrCtxt :: ErrCtxtMsg -> TcM a -> TcM a {-# INLINE addLandmarkErrCtxt #-} -- Note [Inlining addErrCtxt] -addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg)) +addLandmarkErrCtxt msg = addLandmarkErrCtxtM msg -- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations -- and tidying. -addLandmarkErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) -> TcM a -> TcM a +addLandmarkErrCtxtM :: ErrCtxtMsg -> TcM a -> TcM a {-# INLINE addLandmarkErrCtxtM #-} -- Note [Inlining addErrCtxt] addLandmarkErrCtxtM ctxt = pushCtxt (MkErrCtxt LandmarkUserSrcCode ctxt) @@ -1966,14 +1962,14 @@ mkErrCtxt env ctxts go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM [ErrCtxtMsg] go _ _ _ [] = return [] go dbg n env (MkErrCtxt LandmarkUserSrcCode ctxt : ctxts) - = do { (env', msg) <- liftZonkM $ ctxt env - ; rest <- go dbg n env' ctxts - ; return (msg : rest) } + = do { -- (env', msg) <- liftZonkM $ emptyTidyEnv env + ; rest <- go dbg n env ctxts + ; return (ctxt : rest) } go dbg n env (MkErrCtxt _ ctxt : ctxts) | n < mAX_CONTEXTS -- Too verbose || dbg - = do { (env', msg) <- liftZonkM $ ctxt env - ; rest <- go dbg (n+1) env' ctxts - ; return (msg : rest) } + = do { -- (env', msg) <- liftZonkM $ emptyTidyEnv env + ; rest <- go dbg (n+1) env ctxts + ; return (ctxt : rest) } | otherwise = go dbg n env ctxts -- need to compute this for zonking ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -216,7 +216,7 @@ matchActualFunTy herald mb_thing err_info fun_ty ; return (co, arg_ty, res_ty) } ------------ - mk_ctxt :: TcType -> TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg) + mk_ctxt :: TcType -> ErrCtxtMsg mk_ctxt _res_ty = mkFunTysMsg herald err_info {- Note [matchActualFunTy error handling] @@ -959,15 +959,13 @@ new_check_arg_ty herald arg_pos -- Position for error messages only, 1 for first mkFunTysMsg :: CtOrigin -> (VisArity, TcType) - -> TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg) + -> ErrCtxtMsg -- See Note [Reporting application arity errors] -mkFunTysMsg herald (n_vis_args_in_call, fun_ty) env - = do { (env', fun_ty) <- zonkTidyTcType env fun_ty - - ; let (pi_ty_bndrs, _) = splitPiTys fun_ty +mkFunTysMsg herald (n_vis_args_in_call, fun_ty) + = do { let (pi_ty_bndrs, _) = splitPiTys fun_ty n_fun_args = count isVisiblePiTyBinder pi_ty_bndrs - ; return (env', FunTysCtxt herald fun_ty n_vis_args_in_call n_fun_args) } + ; FunTysCtxt herald fun_ty n_vis_args_in_call n_fun_args } {- Note [Reporting application arity errors] @@ -1524,15 +1522,9 @@ addSubTypeCtxt ty_actual ty_expected thing_inside , isRhoExpTy ty_expected -- TypeEqOrigin stuff (added by the _NC functions) = thing_inside -- gives enough context by itself | otherwise - = addErrCtxtM mk_msg thing_inside - where - mk_msg tidy_env - = do { (tidy_env, ty_actual) <- zonkTidyTcType tidy_env ty_actual - ; ty_expected <- readExpType ty_expected - -- A worry: might not be filled if we're debugging. Ugh. - ; (tidy_env, ty_expected) <- zonkTidyTcType tidy_env ty_expected - ; return (tidy_env, SubTypeCtxt ty_expected ty_actual) } - + = do ty_expected <- readExpType ty_expected + addErrCtxtM (SubTypeCtxt ty_expected ty_actual) $ + thing_inside --------------- tc_sub_type :: (TcType -> TcType -> TcM TcCoercionN) -- How to unify ===================================== compiler/GHC/Tc/Validity.hs ===================================== @@ -1182,7 +1182,7 @@ applying the instance decl would show up two uses of ?x. #8912. checkValidTheta :: UserTypeCtxt -> ThetaType -> TcM () -- Assumes argument is fully zonked checkValidTheta ctxt theta - = addErrCtxtM (checkThetaCtxt ctxt theta) $ + = addErrCtxtM (ThetaCtxt ctxt theta) $ do { env <- liftZonkM $ tcInitOpenTidyEnv (tyCoVarsOfTypesList theta) ; expand <- initialExpandMode ; check_valid_theta env ctxt expand theta } @@ -1458,10 +1458,6 @@ Flexibility check: generalized actually. -} -checkThetaCtxt :: UserTypeCtxt -> ThetaType -> TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg) -checkThetaCtxt ctxt theta env - = return (env, ThetaCtxt ctxt (tidyTypes env theta)) - tyConArityErr :: TyCon -> [TcType] -> TcRnMessage -- For type-constructor arity errors, be careful to report -- the number of /visible/ arguments required and supplied, ===================================== compiler/GHC/Unit/State.hs-boot ===================================== @@ -4,4 +4,3 @@ data UnitState data ModuleSuggestion data ModuleOrigin data UnusableUnit -data UnitInfo \ No newline at end of file ===================================== compiler/GHC/Utils/Logger.hs ===================================== @@ -82,10 +82,10 @@ where import GHC.Prelude import GHC.Driver.Flags -import {-# SOURCE #-} GHC.Types.Error - ( MessageClass (..), Severity (..), ResolvedDiagnosticReason, DiagnosticCode - , mkLocMessageWarningGroups,getCaretDiagnostic) -import GHC.Types.Error () +import GHC.Types.Error + ( MessageClass (..), Severity (..) + , mkLocMessageWarningGroups,getCaretDiagnostic ) +-- import GHC.Types.Error () import GHC.Types.SrcLoc import qualified GHC.Utils.Ppr as Pretty View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eac620877dca51c9ba47e85e1a71f8d0... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eac620877dca51c9ba47e85e1a71f8d0... You're receiving this email because of your account on gitlab.haskell.org.