Apoorv Ingle pushed to branch wip/ani/precise-fun-loc at Glasgow Haskell Compiler / GHC Commits: c9af140d by Apoorv Ingle at 2026-04-02T21:19:03-05:00 compute a more accuate application chain head location - - - - - 3 changed files: - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Head.hs - testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr Changes: ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -243,7 +243,7 @@ tcApp accepts 4 arguments: 3. the argument list (types and terms) 4. The expected result type -PRECONDITION : the head (2.) and the list of arguments (3.) will +PRECONDITION : the head (2.) and the list of arguments (3.) are the de-constructred version of the expression (1.) POSTCONDITION: The return expression is the typechecked version of (1.) @@ -365,7 +365,7 @@ tcApp :: HsExpr GhcRn -- ^ The whole application (For error messages) -- See Note [tcApp: typechecking applications] -- See Note [splitHsApps] in GHC.Tc.Head tcApp rn_expr rn_fun rn_args exp_res_ty - = do { fun_lspan <- getFunSrcSpan rn_args + = do { fun_lspan <- getFunSrcSpan rn_fun rn_args ; traceTc "tcApp {" $ vcat [ text "rn_fun:" <+> ppr rn_fun , text "fun_lspan:" <+> ppr fun_lspan @@ -1958,14 +1958,14 @@ quickLookArg1 pos app_lspan rn_head larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_ -- generated by calls in arg do { traceTc "qla1" (ppr arg) - ; (rn_fun_arg, rn_args) <- splitHsApps arg + ; (rn_arg_head, rn_arg_args) <- splitHsApps arg ; traceTc "qla2" (ppr arg) - ; fun_lspan_arg <- getFunSrcSpan rn_args + ; fun_lspan_arg <- getFunSrcSpan rn_arg_head rn_arg_args -- Step 1: get the type of the head of the argument - ; (fun_ue, mb_fun_ty) <- tcCollectingUsage $ tcInferAppHead_maybe rn_fun_arg + ; (fun_ue, mb_fun_ty) <- tcCollectingUsage $ tcInferAppHead_maybe rn_arg_head -- tcCollectingUsage: the use of an Id at the head generates usage-info -- See the call to `tcEmitBindingUsage` in `check_local_id`. So we must -- capture and save it in the `EValArgQL`. See (QLA6) in @@ -1974,8 +1974,8 @@ quickLookArg1 pos app_lspan rn_head larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_ ; traceTc "quickLookArg {" $ vcat [ text "arg:" <+> ppr arg , text "orig_arg_rho:" <+> ppr orig_arg_rho - , text "head:" <+> ppr rn_fun_arg <+> dcolon <+> ppr mb_fun_ty - , text "args:" <+> ppr rn_args ] + , text "head:" <+> ppr rn_arg_head <+> dcolon <+> ppr mb_fun_ty + , text "args:" <+> ppr rn_arg_args ] ; case mb_fun_ty of { Nothing -> skipQuickLook app_lspan larg sc_arg_ty ; -- fun is too complicated @@ -1983,11 +1983,11 @@ quickLookArg1 pos app_lspan rn_head larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_ -- step 2: use |-inst to instantiate the head applied to the arguments do { let arg_tc_head = (tc_fun_arg_head, fun_lspan_arg) - ; do_ql <- wantQuickLook rn_fun_arg + ; do_ql <- wantQuickLook rn_arg_head ; ((inst_args, app_res_rho), wanted) <- captureConstraints $ - tcInstFun do_ql True (rn_fun_arg, fun_lspan_arg) tc_fun_arg_head fun_sigma_arg_head rn_args + tcInstFun do_ql True (rn_arg_head, fun_lspan_arg) tc_fun_arg_head fun_sigma_arg_head rn_arg_args -- We must capture type-class and equality constraints here, but -- not usage information. See (QLA6) in Note [Quick Look at -- value arguments] @@ -2017,13 +2017,13 @@ quickLookArg1 pos app_lspan rn_head larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_ ; when arg_influences_enclosing_call $ qlUnify app_res_rho orig_arg_rho - ; traceTc "quickLookArg done }" (ppr rn_fun_arg) + ; traceTc "quickLookArg done }" (ppr rn_arg_head) ; return (EValArgQL { eaql_loc_span = app_lspan , eaql_arg_ty = sc_arg_ty , eaql_larg = larg , eaql_tc_fun = arg_tc_head - , eaql_rn_fun = rn_fun_arg + , eaql_rn_fun = rn_arg_head , eaql_fun_ue = fun_ue , eaql_args = inst_args , eaql_wanted = wanted ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -223,14 +223,15 @@ addArgWrap wrap args -------------------- -getFunSrcSpan :: [HsExprArg 'TcpRn] -> TcM SrcSpan -getFunSrcSpan [] = getSrcSpanM -getFunSrcSpan (ETypeArg { ea_loc_span = l } : _) = return (locA l) -getFunSrcSpan (EValArg { ea_loc_span = l } : _) = return (locA l) -getFunSrcSpan (EPrag l _ : _) = return (locA l) -getFunSrcSpan (EWrap (EPar l) : _) = return (locA l) -getFunSrcSpan (EWrap (EExpand l _) : _) = return (locA l) -getFunSrcSpan (EWrap (EHsWrap {}) : args) = getFunSrcSpan args +getFunSrcSpan :: HsExpr GhcRn -> [HsExprArg 'TcpRn] -> TcM SrcSpan +getFunSrcSpan (ExprWithTySig _ (L l _) _) _ = return (locA l) +getFunSrcSpan _ [] = getSrcSpanM +getFunSrcSpan _ (ETypeArg { ea_loc_span = l } : _) = return (locA l) +getFunSrcSpan _ (EValArg { ea_loc_span = l } : _) = return (locA l) +getFunSrcSpan _ (EPrag l _ : _) = return (locA l) +getFunSrcSpan _ (EWrap (EPar l) : _) = return (locA l) +getFunSrcSpan _ (EWrap (EExpand l _) : _) = return (locA l) +getFunSrcSpan f (EWrap (EHsWrap {}) : args) = getFunSrcSpan f args -------------------- isHsValArg :: HsExprArg id -> Bool @@ -294,10 +295,10 @@ instance Outputable EWrap where splitHsApps :: HsExpr GhcRn -> TcM (HsExpr GhcRn, [HsExprArg 'TcpRn]) splitHsApps e = go e [] where - go (HsPar _ (L l fun)) args = go fun (EWrap (EPar l) : args) - go (HsPragE _ p (L l fun)) args = go fun (EPrag l p : args) - go (HsAppType _ (L l fun) ty) args = go fun (mkETypeArg l ty : args) - go (HsApp _ (L l fun) arg) args = go fun (mkEValArg l arg : args) + go (HsPar _ (L l fun)) args = go fun (EWrap (EPar l) : args) + go (HsPragE _ p (L l fun)) args = go fun (EPrag l p : args) + go (HsAppType _ (L l fun) ty) args = go fun (mkETypeArg l ty : args) + go (HsApp _ (L l fun) arg) args = go fun (mkEValArg l arg : args) go fun args = do { mb_hse <- tcExpand fun ; case mb_hse of Just (HSE { hse_ctxt = orig, hse_exp = L l fun' }) ===================================== testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr ===================================== @@ -20,7 +20,8 @@ SplicesUsed.hs:8:26: warning: [GHC-88464] [-Wpartial-type-signatures (in -Wdefau • Found type wildcard ‘_’ standing for ‘Bool’ • In the first argument of ‘Maybe’, namely ‘_’ In an expression type signature: Maybe _ - In the expression: Just True :: Maybe _ + In the first argument of ‘id :: _a -> _a’, namely + ‘(Just True :: Maybe _)’ • Relevant bindings include maybeBool :: Maybe Bool (bound at SplicesUsed.hs:8:1) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c9af140d496ca06466d1d14678fe9094... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c9af140d496ca06466d1d14678fe9094... You're receiving this email because of your account on gitlab.haskell.org.