GitLab

Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC

Commits:

1d4f129b

by Apoorv Ingle at 2025-11-17T10:42:07-06:00

fix quickLookArg function to blame the correct application chain head. The arguments application chain head should be blamed, not the original head when we quick look arg

3 changed files:

compiler/GHC/Tc/Gen/App.hs
compiler/GHC/Tc/Gen/Expr.hs
compiler/GHC/Tc/Gen/Head.hs

Changes:

compiler/GHC/Tc/Gen/App.hs

@@ -2002,19 +2002,19 @@ quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L _ arg) sc_arg_ty@(Scaled _
         ; case mb_fun_ty of {
             Nothing -> skipQuickLook app_lspan larg sc_arg_ty ;    -- fun is too complicated
 -           Just (tc_fun, fun_sigma) ->
 +           Just (tc_fun_arg_head, fun_sigma_arg_head) ->
         -- step 2: use |-inst to instantiate the head applied to the arguments
 -    do { let tc_head = (tc_fun, fun_lspan)
 +    do { let arg_tc_head = (tc_fun_arg_head, fun_lspan_arg)
         ; do_ql <- wantQuickLook rn_fun_arg
         ; code_orig <- getSrcCodeOrigin
         ; let arg_orig | not (isGeneratedSrcSpan fun_lspan_arg)
 -                      = exprCtOrigin fun
 +                      = exprCtOrigin rn_fun_arg
                        | otherwise
                        = srcCodeOriginCtOrigin fun code_orig
         ; ((inst_args, app_res_rho), wanted)
               <- captureConstraints $
 -                tcInstFun do_ql True (arg_orig, rn_fun_arg, fun_lspan_arg) tc_fun fun_sigma rn_args
 +                tcInstFun do_ql True (arg_orig, rn_fun_arg, fun_lspan_arg) tc_fun_arg_head fun_sigma_arg_head rn_args
                  -- We must capture type-class and equality constraints here, but
                  -- not equality constraints.  See (QLA6) in Note [Quick Look at
                  -- value arguments]
@@ -2049,7 +2049,7 @@ quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L _ arg) sc_arg_ty@(Scaled _
         ; return (EValArgQL { eaql_loc_span = app_lspan
                             , eaql_arg_ty   = sc_arg_ty
                             , eaql_larg     = larg
 -                           , eaql_tc_fun   = tc_head
 +                           , eaql_tc_fun   = arg_tc_head
                             , eaql_rn_fun   = rn_fun_arg
                             , eaql_fun_ue   = fun_ue
                             , eaql_args     = inst_args

compiler/GHC/Tc/Gen/Expr.hs

@@ -1506,7 +1506,6 @@ expandRecordUpd record_expr possible_parents rbnds res_ty
                   , text "ds_res_ty:" <+> ppr ds_res_ty
                   , text "ds_expr:" <+> ppr ds_expr
+                  ]
+-
          ; return (ds_expr, ds_res_ty, RecordUpdCtxt relevant_cons upd_fld_names ex_tvs) }

compiler/GHC/Tc/Gen/Head.hs

@@ -465,7 +465,7 @@ 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) $ -- ANI: TODO this is fishy..
                                                -- We do not want to instantiate c.f. T19167
                                                tcExprSigma False e
+                                               )