Apoorv Ingle pushed to branch wip/ani/kill-popErrCtxt at Glasgow Haskell Compiler / GHC Commits: eb9ac0c9 by Apoorv Ingle at 2025-10-30T13:27:46-05:00 pass in the location of the head of the application chain to addArgCtxt to print better error messages - - - - - 3 changed files: - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Do.hs - compiler/GHC/Tc/Gen/Head.hs Changes: ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -175,6 +175,9 @@ Note [Instantiation variables are short lived] -- CAUTION: Any changes to tcApp should be reflected here -- cf. T19167. the head is an expanded expression applied to a type -- TODO: Use runInfer for tcExprSigma? +-- Caution: Currently we assume that the expression is compiler generated/expanded +-- Becuase that is that T19167 testcase generates. This function can possibly +-- take in the rn_expr and its location to pass into tcValArgs tcExprSigma :: Bool -> HsExpr GhcRn -> TcM (HsExpr GhcTc, TcSigmaType) tcExprSigma inst rn_expr = do { (fun@(rn_fun,fun_ctxt), rn_args) <- splitHsApps rn_expr @@ -183,7 +186,7 @@ tcExprSigma inst rn_expr ; code_orig <- getSrcCodeOrigin ; let fun_orig = srcCodeOriginCtOrigin rn_expr code_orig ; (inst_args, app_res_sigma) <- tcInstFun do_ql inst fun_orig (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args - ; tc_args <- tcValArgs do_ql rn_fun inst_args + ; tc_args <- tcValArgs do_ql (rn_fun, generatedSrcSpan) inst_args ; let tc_expr = rebuildHsApps (tc_fun, fun_ctxt) tc_args ; return (tc_expr, app_res_sigma) } @@ -396,18 +399,18 @@ tcApp :: HsExpr GhcRn -- See Note [tcApp: typechecking applications] tcApp rn_expr exp_res_ty = do { -- Step 1: Split the application chain - (fun@(rn_fun, fun_loc), rn_args) <- splitHsApps rn_expr + (fun@(rn_fun, fun_lspan), rn_args) <- splitHsApps rn_expr ; inGenCode <- inGeneratedCode ; traceTc "tcApp {" $ vcat [ text "generated? " <+> ppr inGenCode , text "rn_expr:" <+> ppr rn_expr , text "rn_fun:" <+> ppr rn_fun - , text "fun_loc:" <+> ppr fun_loc + , text "fun_lspan:" <+> ppr fun_lspan , text "rn_args:" <+> ppr rn_args ] -- Step 2: Infer the type of `fun`, the head of the application ; (tc_fun, fun_sigma) <- tcInferAppHead fun - ; let tc_head = (tc_fun, fun_loc) + ; let tc_head = (tc_fun, fun_lspan) -- inst_final: top-instantiate the result type of the application, -- EXCEPT if we are trying to infer a sigma-type inst_final = case exp_res_ty of @@ -438,7 +441,7 @@ tcApp rn_expr exp_res_ty , text "fun_origin" <+> ppr fun_orig , text "do_ql:" <+> ppr do_ql] ; (inst_args, app_res_rho) - <- tcInstFun do_ql inst_final fun_orig (tc_fun, rn_fun, fun_loc) fun_sigma rn_args + <- tcInstFun do_ql inst_final fun_orig (tc_fun, rn_fun, fun_lspan) fun_sigma rn_args -- See (TCAPP1) and (TCAPP2) in -- Note [tcApp: typechecking applications] @@ -451,7 +454,7 @@ tcApp rn_expr exp_res_ty app_res_rho exp_res_ty -- Step 4.2: typecheck the arguments - ; tc_args <- tcValArgs NoQL rn_fun inst_args + ; tc_args <- tcValArgs NoQL (rn_fun, fun_lspan) inst_args -- Step 4.3: wrap up ; finishApp tc_head tc_args app_res_rho res_wrap } @@ -462,7 +465,7 @@ tcApp rn_expr exp_res_ty -- Step 5.2: typecheck the arguments, and monomorphise -- any un-unified instantiation variables - ; tc_args <- tcValArgs DoQL rn_fun inst_args + ; tc_args <- tcValArgs DoQL (rn_fun, fun_lspan) inst_args -- Step 5.3: zonk to expose the polymorphism hidden under -- QuickLook instantiation variables in `app_res_rho` ; app_res_rho <- liftZonkM $ zonkTcType app_res_rho @@ -549,16 +552,16 @@ checkResultTy rn_expr (tc_fun, fun_loc) inst_args app_res_rho (Check res_ty) thing_inside ---------------- -tcValArgs :: QLFlag -> HsExpr GhcRn -> [HsExprArg 'TcpInst] -> TcM [HsExprArg 'TcpTc] +tcValArgs :: QLFlag -> (HsExpr GhcRn, SrcSpan) -> [HsExprArg 'TcpInst] -> TcM [HsExprArg 'TcpTc] -- Importantly, tcValArgs works left-to-right, so that by the time we -- encounter an argument, we have monomorphised all the instantiation -- variables that its type contains. All that is left to do is an ordinary -- zonkTcType. See Note [Monomorphise instantiation variables]. -tcValArgs do_ql fun args = go do_ql 0 args +tcValArgs do_ql (fun, fun_lspan) args = go do_ql 0 args where go _ _ [] = return [] go do_ql pos (arg : args) = - do { arg' <- tcValArg do_ql pos' fun arg + do { arg' <- tcValArg do_ql pos' (fun, fun_lspan) arg ; args' <- go do_ql pos' args ; return (arg' : args') } where @@ -574,7 +577,7 @@ tcValArgs do_ql fun args = go do_ql 0 args = pos -tcValArg :: QLFlag -> Int -> HsExpr GhcRn -> HsExprArg 'TcpInst -- Actual argument +tcValArg :: QLFlag -> Int -> (HsExpr GhcRn, SrcSpan) -> HsExprArg 'TcpInst -- Actual argument -> TcM (HsExprArg 'TcpTc) -- Resulting argument tcValArg _ _ _ (EPrag l p) = return (EPrag l (tcExprPrag p)) tcValArg _ _ _ (ETypeArg l hty ty) = return (ETypeArg l hty ty) @@ -583,10 +586,10 @@ tcValArg do_ql _ _ (EWrap (EHsWrap w)) = do { whenQL do_ql $ qlMonoHsWrapper w -- qlMonoHsWrapper: see Note [Monomorphise instantiation variables] tcValArg _ _ _ (EWrap ew) = return (EWrap ew) -tcValArg do_ql pos fun (EValArg { ea_loc_span = lspan +tcValArg do_ql pos (fun, fun_lspan) (EValArg { ea_loc_span = lspan , ea_arg = larg@(L arg_loc arg) , ea_arg_ty = sc_arg_ty }) - = addArgCtxt pos fun larg $ + = addArgCtxt pos (fun, fun_lspan) larg $ do { -- Crucial step: expose QL results before checking exp_arg_ty -- So far as the paper is concerned, this step applies -- the poly-substitution Theta, learned by QL, so that we @@ -601,6 +604,7 @@ tcValArg do_ql pos fun (EValArg { ea_loc_span = lspan NoQL -> return sc_arg_ty ; traceTc "tcValArg {" $ vcat [ text "lspan:" <+> ppr lspan + , text "fun_lspan" <+> ppr fun_lspan , text "sigma_type" <+> ppr (mkCheckExpType exp_arg_ty) , text "arg:" <+> ppr larg ] @@ -615,7 +619,7 @@ tcValArg do_ql pos fun (EValArg { ea_loc_span = lspan , ea_arg = L arg_loc arg' , ea_arg_ty = noExtField }) } -tcValArg _ pos fun (EValArgQL { +tcValArg _ pos (fun, fun_lspan) (EValArgQL { eaql_wanted = wanted , eaql_loc_span = lspan , eaql_arg_ty = sc_arg_ty @@ -626,7 +630,7 @@ tcValArg _ pos fun (EValArgQL { , eaql_args = inst_args , eaql_encl = arg_influences_enclosing_call , eaql_res_rho = app_res_rho }) - = addArgCtxt pos fun larg $ + = addArgCtxt pos (fun, fun_lspan) larg $ do { -- Expose QL results to tcSkolemise, as in EValArg case Scaled mult exp_arg_ty <- liftZonkM $ zonkScaledTcType sc_arg_ty @@ -635,6 +639,8 @@ tcValArg _ pos fun (EValArgQL { , text "args:" <+> ppr inst_args , text "mult:" <+> ppr mult , text "fun" <+> ppr fun + , text "app_lspan" <+> ppr lspan + , text "head_lspan" <+> ppr fun_lspan , text "tc_head" <+> ppr tc_head]) ; ds_flag <- getDeepSubsumptionFlag @@ -653,7 +659,7 @@ tcValArg _ pos fun (EValArgQL { ; unless arg_influences_enclosing_call $ -- Don't repeat qlUnify app_res_rho exp_arg_rho -- the qlUnify - ; tc_args <- tcValArgs DoQL rn_fun inst_args + ; tc_args <- tcValArgs DoQL (rn_fun, snd tc_head) inst_args ; app_res_rho <- liftZonkM $ zonkTcType app_res_rho ; res_wrap <- checkResultTy rn_expr tc_head inst_args app_res_rho (mkCheckExpType exp_arg_rho) @@ -696,20 +702,20 @@ tcInstFun :: QLFlag -- Generally speaking we pass in True; in Fig 5 of the paper -- |-inst returns a rho-type -> CtOrigin - -> (HsExpr GhcTc, HsExpr GhcRn, SrcSpan) + -> (HsExpr GhcTc, HsExpr GhcRn, SrcSpan) -- ANI: TODO, move HsExpr GhcRn, SrcSpan to CtOrigin -> TcSigmaType -> [HsExprArg 'TcpRn] -> TcM ( [HsExprArg 'TcpInst] , TcSigmaType ) -- Does not instantiate trailing invisible foralls -- This crucial function implements the |-inst judgement in Fig 4, plus the -- modification in Fig 5, of the QL paper: -- "A quick look at impredicativity" (ICFP'20). -tcInstFun do_ql inst_final fun_orig (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args +tcInstFun do_ql inst_final fun_orig (tc_fun, rn_fun, fun_lspan) fun_sigma rn_args = do { traceTc "tcInstFun" (vcat [ text "origin" <+> ppr fun_orig , text "tc_fun" <+> ppr tc_fun , text "fun_sigma" <+> ppr fun_sigma , text "args:" <+> ppr rn_args , text "do_ql" <+> ppr do_ql - , text "ctx" <+> ppr fun_ctxt]) + , text "ctx" <+> ppr fun_lspan]) ; setQLInstLevel do_ql $ -- See (TCAPP1) and (TCAPP2) in -- Note [tcApp: typechecking applications] go 1 [] fun_sigma rn_args } @@ -786,7 +792,7 @@ tcInstFun do_ql inst_final fun_orig (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args = do { (_inst_tvs, wrap, fun_rho) <- -- addHeadCtxt: important for the class constraints -- that may be emitted from instantiating fun_sigma - setSrcSpan fun_ctxt $ + setSrcSpan fun_lspan $ instantiateSigma fun_orig fun_conc_tvs tvs theta body2 -- See Note [Representation-polymorphism checking built-ins] -- in GHC.Tc.Utils.Concrete. @@ -881,7 +887,7 @@ tcInstFun do_ql inst_final fun_orig (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args (Just $ HsExprTcThing tc_fun) (n_val_args, fun_sigma) fun_ty - ; arg' <- quickLookArg do_ql pos ctxt rn_fun arg arg_ty + ; arg' <- quickLookArg do_ql pos ctxt (rn_fun, fun_lspan) arg arg_ty ; let acc' = arg' : addArgWrap wrap acc ; go (pos+1) acc' res_ty rest_args } @@ -931,7 +937,7 @@ looks_like_type_arg EValArg{ ea_arg = L _ e } = _ -> False looks_like_type_arg _ = False -addArgCtxt :: Int -> HsExpr GhcRn -> LHsExpr GhcRn +addArgCtxt :: Int -> (HsExpr GhcRn, SrcSpan) -> LHsExpr GhcRn -> TcM a -> TcM a -- There are 2 cases: -- 1. In the normal case, we add an informative context (<=> `inGeneratedCode` is `False`) @@ -942,7 +948,7 @@ addArgCtxt :: Int -> HsExpr GhcRn -> LHsExpr GhcRn -- (iii) if arg_loc is RealSrcLoc then update tcl_loc and add "In the expression: arg" to ErrCtxtStack -- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr -- See Note [Expanding HsDo with XXExprGhcRn] in GHC.Tc.Gen.Do -addArgCtxt arg_no fun (L arg_loc arg) thing_inside +addArgCtxt arg_no (fun, fun_lspan) (L arg_loc arg) thing_inside = do { in_generated_code <- inGeneratedCode ; err_ctx <- getErrCtxt ; env0 <- liftZonkM tcInitTidyEnv @@ -951,12 +957,14 @@ addArgCtxt arg_no fun (L arg_loc arg) thing_inside , text "arg: " <+> ppr (arg, arg_no) , text "arg_loc:" <+> ppr arg_loc , text "fun:" <+> ppr fun - , text "err_ctx" <+> vcat (fmap (\ (x, y) -> case x of - MkErrCtxt (ExpansionCodeCtxt{}) _ -> text "<EXPN>" <+> pprErrCtxtMsg y - _ -> text "<USER>" <+> pprErrCtxtMsg y) - (take 4 (zip err_ctx err_ctx_msg))) + , text "fun_lspan" <+> ppr fun_lspan + , text "err_ctx" <+> vcat (fmap (\ (x, y) -> + case x of + MkErrCtxt (ExpansionCodeCtxt{}) _ -> text "<EXPN>" <+> pprErrCtxtMsg y + _ -> text "<USER>" <+> pprErrCtxtMsg y) + (take 4 (zip err_ctx err_ctx_msg))) ]) - ; if in_generated_code + ; if in_generated_code && isGeneratedSrcSpan fun_lspan then updCtxtForArg (L arg_loc arg) $ thing_inside else do setSrcSpanA arg_loc $ @@ -1745,24 +1753,26 @@ This turned out to be more subtle than I expected. Wrinkles: -} -quickLookArg :: QLFlag -> Int -> SrcSpan -> HsExpr GhcRn +quickLookArg :: QLFlag -> Int + -> SrcSpan -- ^ location span of the whole application + -> (HsExpr GhcRn, SrcSpan) -- ^ Head of the application chain and its source span -> LHsExpr GhcRn -- ^ Argument -> Scaled TcSigmaTypeFRR -- ^ Type expected by the function -> TcM (HsExprArg 'TcpInst) -- See Note [Quick Look at value arguments] -quickLookArg NoQL _ ctxt _ larg orig_arg_ty - = skipQuickLook ctxt larg orig_arg_ty -quickLookArg DoQL pos ctxt fun larg orig_arg_ty +quickLookArg NoQL _ app_lspan _ larg orig_arg_ty + = skipQuickLook app_lspan larg orig_arg_ty +quickLookArg DoQL pos app_lspan fun_and_lspan larg orig_arg_ty = do { is_rho <- tcIsDeepRho (scaledThing orig_arg_ty) ; traceTc "qla" (ppr orig_arg_ty $$ ppr is_rho) ; if not is_rho - then skipQuickLook ctxt larg orig_arg_ty - else quickLookArg1 pos ctxt fun larg orig_arg_ty } + then skipQuickLook app_lspan larg orig_arg_ty + else quickLookArg1 pos app_lspan fun_and_lspan larg orig_arg_ty } skipQuickLook :: SrcSpan -> LHsExpr GhcRn -> Scaled TcRhoType -> TcM (HsExprArg 'TcpInst) -skipQuickLook ctxt larg arg_ty - = return (EValArg { ea_loc_span = ctxt +skipQuickLook app_lspan larg arg_ty + = return (EValArg { ea_loc_span = app_lspan , ea_arg = larg , ea_arg_ty = arg_ty }) @@ -1800,14 +1810,14 @@ isGuardedTy ty | Just {} <- tcSplitAppTy_maybe ty = True | otherwise = False -quickLookArg1 :: Int -> SrcSpan -> HsExpr GhcRn -> LHsExpr GhcRn +quickLookArg1 :: Int -> SrcSpan -> (HsExpr GhcRn, SrcSpan) -> LHsExpr GhcRn -> Scaled TcRhoType -- Deeply skolemised -> TcM (HsExprArg 'TcpInst) -- quickLookArg1 implements the "QL Argument" judgement in Fig 5 of the paper -quickLookArg1 pos ctxt fun larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho) - = addArgCtxt pos fun larg $ -- Context needed for constraints +quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho) + = addArgCtxt pos (fun, fun_lspan) larg $ -- Context needed for constraints -- generated by calls in arg - do { ((rn_fun, fun_ctxt), rn_args) <- splitHsApps arg + do { ((rn_fun, fun_lspan), rn_args) <- splitHsApps arg -- Step 1: get the type of the head of the argument ; (fun_ue, mb_fun_ty) <- tcCollectingUsage $ tcInferAppHead_maybe rn_fun @@ -1823,15 +1833,15 @@ quickLookArg1 pos ctxt fun larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho) , text "args:" <+> ppr rn_args ] ; case mb_fun_ty of { - Nothing -> skipQuickLook ctxt larg sc_arg_ty ; -- fun is too complicated + Nothing -> skipQuickLook app_lspan larg sc_arg_ty ; -- fun is too complicated Just (tc_fun, fun_sigma) -> -- step 2: use |-inst to instantiate the head applied to the arguments - do { let tc_head = (tc_fun, fun_ctxt) + do { let tc_head = (tc_fun, fun_lspan) ; do_ql <- wantQuickLook rn_fun ; ((inst_args, app_res_rho), wanted) <- captureConstraints $ - tcInstFun do_ql True (exprCtOrigin arg) (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args + tcInstFun do_ql True (exprCtOrigin arg) (tc_fun, rn_fun, fun_lspan) fun_sigma rn_args -- We must capture type-class and equality constraints here, but -- not equality constraints. See (QLA6) in Note [Quick Look at -- value arguments] @@ -1863,7 +1873,7 @@ quickLookArg1 pos ctxt fun larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho) ; traceTc "quickLookArg done }" (ppr rn_fun) - ; return (EValArgQL { eaql_loc_span = ctxt + ; return (EValArgQL { eaql_loc_span = app_lspan , eaql_arg_ty = sc_arg_ty , eaql_larg = larg , eaql_tc_fun = tc_head ===================================== compiler/GHC/Tc/Gen/Do.hs ===================================== @@ -81,7 +81,7 @@ expand_do_stmts flav [stmt@(L sloc (LastStmt _ body@(L body_loc _) _ ret_expr))] -- See `checkLastStmt` and `Syntax.Expr.StmtLR.LastStmt` | NoSyntaxExprRn <- ret_expr -- Last statement is just body if we are not in ListComp context. See Syntax.Expr.LastStmt - = return $ L sloc (mkExpandedLastStmt (HsPar noExtField body)) + = return $ L sloc (mkExpandedStmt stmt flav (HsPar noExtField body)) | SyntaxExprRn ret <- ret_expr -- We have unfortunately lost the location on the return function :( -- @@ -89,7 +89,7 @@ expand_do_stmts flav [stmt@(L sloc (LastStmt _ body@(L body_loc _) _ ret_expr))] -- return e ~~> return e -- to make T18324 work = do let expansion = L body_loc (genHsApp ret body) - return $ L sloc (mkExpandedLastStmt (HsPar noExtField expansion)) + return $ L sloc (mkExpandedStmt stmt flav (HsPar noExtField expansion)) expand_do_stmts doFlavour (stmt@(L loc (LetStmt _ bs)) : lstmts) = -- See Note [Expanding HsDo with XXExprGhcRn] Equation (3) below @@ -118,7 +118,7 @@ expand_do_stmts doFlavour (stmt@(L loc (BindStmt xbsrn pat e)): lstmts) | otherwise = pprPanic "expand_do_stmts: The impossible happened, missing bind operator from renamer" (text "stmt" <+> ppr stmt) -expand_do_stmts doFlavour (stmt@(L loc (BodyStmt _ e (SyntaxExprRn then_op) _)) : lstmts) = +expand_do_stmts doFlavour (stmt@(L loc (BodyStmt _ (L e_lspan e) (SyntaxExprRn then_op) _)) : lstmts) = -- See Note [BodyStmt] in Language.Haskell.Syntax.Expr -- See Note [Expanding HsDo with XXExprGhcRn] Equation (1) below -- stmts ~~> stmts' @@ -126,7 +126,7 @@ expand_do_stmts doFlavour (stmt@(L loc (BodyStmt _ e (SyntaxExprRn then_op) _)) -- e ; stmts ~~> (>>) e stmts' do expand_stmts_expr <- expand_do_stmts doFlavour lstmts let expansion = genHsExpApps then_op -- (>>) - [ e + [ L e_lspan (mkExpandedStmt stmt doFlavour e) , expand_stmts_expr ] return $ L loc (mkExpandedStmt stmt doFlavour expansion) @@ -486,3 +486,6 @@ It stores the original statement (with location) and the expanded expression mkExpandedPatRn :: Pat GhcRn -> HsExpr GhcRn -> HsExpr GhcRn mkExpandedPatRn pat e = XExpr (ExpandedThingRn (OrigPat pat) e) + +mkPopErrCtxtExprRn :: HsExpr GhcRn -> HsExpr GhcRn +mkPopErrCtxtExprRn e = XExpr (ExpandedThingRn PopErrCtxt e) ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -175,7 +175,7 @@ data HsExprArg (p :: TcPass) where -- See Note [HsExprArg] , eaql_larg :: LHsExpr GhcRn -- Original application, for -- location and error msgs , eaql_rn_fun :: HsExpr GhcRn -- Head of the argument if it is an application - , eaql_tc_fun :: (HsExpr GhcTc, SrcSpan) -- Typechecked head + , eaql_tc_fun :: (HsExpr GhcTc, SrcSpan) -- Typechecked head and its location span , eaql_fun_ue :: UsageEnv -- Usage environment of the typechecked head (QLA5) , eaql_args :: [HsExprArg 'TcpInst] -- Args: instantiated, not typechecked , eaql_wanted :: WantedConstraints @@ -456,8 +456,8 @@ tcInferAppHead :: (HsExpr GhcRn, SrcSpan) -- cases are dealt with by splitHsApps. -- -- See Note [tcApp: typechecking applications] in GHC.Tc.Gen.App -tcInferAppHead (fun,fun_loc) - = setSrcSpan fun_loc $ +tcInferAppHead (fun,fun_lspan) + = setSrcSpan fun_lspan $ do { mb_tc_fun <- tcInferAppHead_maybe fun ; case mb_tc_fun of Just (fun', fun_sigma) -> return (fun', fun_sigma) @@ -471,7 +471,8 @@ tcInferAppHead_maybe fun = case fun of HsVar _ nm -> Just <$> tcInferId nm XExpr (HsRecSelRn f) -> Just <$> tcInferRecSelId f - XExpr (ExpandedThingRn o e) -> Just <$> (addExpansionErrCtxt o (srcCodeOriginErrCtxMsg o) $ -- We do not want to instantiate c.f. T19167 + XExpr (ExpandedThingRn o e) -> Just <$> (addExpansionErrCtxt o (srcCodeOriginErrCtxMsg o) $ + -- We do not want to instantiate c.f. T19167 tcExprSigma False e) ExprWithTySig _ e hs_ty -> Just <$> tcExprWithSig e hs_ty HsOverLit _ lit -> Just <$> tcInferOverLit lit View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eb9ac0c913c9c4218eb868081aab64e0... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eb9ac0c913c9c4218eb868081aab64e0... You're receiving this email because of your account on gitlab.haskell.org.