Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: cd46879a by Apoorv Ingle at 2025-11-03T19:32:17-06:00 fun_orig in tcApp depends on the SrcSpan of the head of the application chain (similar to addArgCtxt) - - - - - 3 changed files: - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Head.hs - testsuite/tests/rebindable/rebindable6.stderr Changes: ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -183,7 +183,7 @@ tcExprSigma inst rn_expr ; (tc_fun, fun_sigma) <- tcInferAppHead fun ; 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 + ; (inst_args, app_res_sigma) <- tcInstFun do_ql inst (fun_orig, rn_fun, fun_ctxt) tc_fun fun_sigma rn_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) } @@ -424,14 +424,17 @@ tcApp rn_expr exp_res_ty -- Setp 3.2 Set the correct origin to blame for the error message -- What should be the origin for this function call? - -- If we are in generated code, blame it on the + -- If the head of the function is user written + -- then it can be used in the error message + -- If it is generated code location span, blame it on the -- source code origin stored in the lclEnv. - -- If not, the head of the function is user written - -- and can be used in the error message -- See Note [Error contexts in generated code] -- See Note [Error Context Stack] ; code_orig <- getSrcCodeOrigin - ; let fun_orig = srcCodeOriginCtOrigin rn_fun code_orig + ; let fun_orig | isGoodSrcSpan fun_lspan + = exprCtOrigin rn_fun + | otherwise + = srcCodeOriginCtOrigin rn_fun code_orig ; traceTc "tcApp:inferAppHead" $ vcat [ text "tc_fun:" <+> ppr tc_fun @@ -439,7 +442,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_lspan) fun_sigma rn_args + <- tcInstFun do_ql inst_final (fun_orig, rn_fun, fun_lspan) tc_fun fun_sigma rn_args -- See (TCAPP1) and (TCAPP2) in -- Note [tcApp: typechecking applications] @@ -699,15 +702,15 @@ tcInstFun :: QLFlag -- always return a rho-type (but not a deep-rho type) -- Generally speaking we pass in True; in Fig 5 of the paper -- |-inst returns a rho-type - -> CtOrigin - -> (HsExpr GhcTc, HsExpr GhcRn, SrcSpan) -- ANI: TODO, move HsExpr GhcRn, SrcSpan to CtOrigin + -> (CtOrigin, HsExpr GhcRn, SrcSpan) + -> HsExpr GhcTc -- 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_lspan) fun_sigma rn_args +tcInstFun do_ql inst_final (fun_orig, rn_fun, fun_lspan) tc_fun 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 @@ -1819,7 +1822,7 @@ quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L _ arg) sc_arg_ty@(Scaled _ ; do_ql <- wantQuickLook rn_fun ; ((inst_args, app_res_rho), wanted) <- captureConstraints $ - tcInstFun do_ql True (exprCtOrigin arg) (tc_fun, rn_fun, fun_lspan) fun_sigma rn_args + tcInstFun do_ql True (exprCtOrigin arg, rn_fun, fun_lspan) tc_fun 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] ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -457,7 +457,7 @@ tcInferAppHead :: (HsExpr GhcRn, SrcSpan) -- -- See Note [tcApp: typechecking applications] in GHC.Tc.Gen.App tcInferAppHead (fun,fun_lspan) - = setSrcSpan fun_lspan $ + = addLExprCtxt fun_lspan fun $ do { mb_tc_fun <- tcInferAppHead_maybe fun ; case mb_tc_fun of Just (fun', fun_sigma) -> return (fun', fun_sigma) @@ -471,9 +471,10 @@ 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) $ + XExpr (ExpandedThingRn _ e) -> Just <$> -- (addExpansionErrCtxt o (srcCodeOriginErrCtxMsg o) $ -- We do not want to instantiate c.f. T19167 - tcExprSigma False e) + tcExprSigma False e + -- ) ExprWithTySig _ e hs_ty -> Just <$> tcExprWithSig e hs_ty HsOverLit _ lit -> Just <$> tcInferOverLit lit _ -> return Nothing ===================================== testsuite/tests/rebindable/rebindable6.stderr ===================================== @@ -49,7 +49,7 @@ rebindable6.hs:111:17: error: [GHC-39999] return b rebindable6.hs:112:17: error: [GHC-39999] - • Ambiguous type variable ‘t1’ arising from a do statement + • Ambiguous type variable ‘t1’ arising from a use of ‘return’ prevents the constraint ‘(HasReturn (b -> t1))’ from being solved. (maybe you haven't applied a function to enough arguments?) Relevant bindings include View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cd46879a9794392698308962d4982d51... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cd46879a9794392698308962d4982d51... You're receiving this email because of your account on gitlab.haskell.org.