GitLab

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

Commits:

82766264

by Apoorv Ingle at 2025-11-04T09:57:14-06:00

rename fun_ctxt to fun_lspan, fun_orig passed in tcInstFun to default to app chain head if its user located, fall back to srcCodeOrigin if it's a generated location

2 changed files:

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

Changes:

compiler/GHC/Tc/Gen/App.hs

@@ -178,14 +178,17 @@ Note [Instantiation variables are short lived]
  -- 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
 +  = do { (fun@(rn_fun,fun_lspan), rn_args) <- splitHsApps rn_expr
         ; do_ql <- wantQuickLook rn_fun
         ; (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, 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
 +       ; let fun_orig | isGoodSrcSpan fun_lspan
 +                      = exprCtOrigin rn_fun
 +                      | otherwise
 +                      = srcCodeOriginCtOrigin rn_fun code_orig
 +       ; (inst_args, app_res_sigma) <- tcInstFun do_ql inst (fun_orig, rn_fun, fun_lspan) tc_fun fun_sigma rn_args
 +       ; tc_args <- tcValArgs do_ql (rn_fun, fun_lspan) inst_args
 +       ; let tc_expr = rebuildHsApps (tc_fun, fun_lspan) tc_args
         ; return (tc_expr, app_res_sigma) }
@@ -2239,7 +2242,7 @@ tcTagToEnum :: (HsExpr GhcTc, SrcSpan) -> [HsExprArg 'TcpTc]
              -> TcM (HsExpr GhcTc)
  -- tagToEnum# :: forall a. Int# -> a
  -- See Note [tagToEnum#]   Urgh!
 -tcTagToEnum (tc_fun, fun_ctxt) tc_args res_ty
 +tcTagToEnum (tc_fun, fun_lspan) tc_args res_ty
    | [val_arg] <- dropWhile (not . isHsValArg) tc_args
    = do { res_ty <- liftZonkM $ zonkTcType res_ty
@@ -2261,14 +2264,14 @@ tcTagToEnum (tc_fun, fun_ctxt) tc_args res_ty
         ; let rep_ty  = mkTyConApp rep_tc rep_args
               tc_fun' = mkHsWrap (WpTyApp rep_ty) tc_fun
               df_wrap = mkWpCastR (mkSymCo coi)
 -             tc_expr = rebuildHsApps (tc_fun', fun_ctxt) [val_arg]
 +             tc_expr = rebuildHsApps (tc_fun', fun_lspan) [val_arg]
         ; return (mkHsWrap df_wrap tc_expr) }}}}}
    | otherwise
    = failWithTc TcRnTagToEnumMissingValArg
    where
 -    vanilla_result = return (rebuildHsApps (tc_fun, fun_ctxt) tc_args)
 +    vanilla_result = return (rebuildHsApps (tc_fun, fun_lspan) tc_args)
      check_enumeration ty' tc
        | -- isTypeDataTyCon: see wrinkle (W1) in

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)
 -  = addLExprCtxt fun_lspan fun $
 +  = setSrcSpan fun_lspan $
      do { mb_tc_fun <- tcInferAppHead_maybe fun
         ; case mb_tc_fun of
              Just (fun', fun_sigma) -> return (fun', fun_sigma)
@@ -471,10 +471,10 @@ tcInferAppHead_maybe fun =
      case fun of
        HsVar _ nm                  -> Just <$> tcInferId nm
        XExpr (HsRecSelRn f)        -> Just <$> tcInferRecSelId f
 -      XExpr (ExpandedThingRn _ e) -> Just <$> -- (addExpansionErrCtxt o (srcCodeOriginErrCtxMsg o) $
 +      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
        _                           -> return Nothing