Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: 8fed9248 by Apoorv Ingle at 2025-11-26T23:31:45-06:00 GhcRn -> GhcTc lost the location of the first statement. fix for test T14546d - - - - - 5e9b41d5 by Apoorv Ingle at 2025-11-27T01:14:17-06:00 during QL arg head instantiation use more a more accurate location for arg when the application chain is null - - - - - 5 changed files: - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/Unify.hs Changes: ===================================== compiler/GHC/HsToCore/Expr.hs ===================================== @@ -296,7 +296,11 @@ dsExpr e@(XExpr ext_expr_tc) WrapExpr {} -> dsApp e ConLikeTc {} -> dsApp e - ExpandedThingTc _ e -> dsExpr e + ExpandedThingTc o e + | OrigStmt (L loc _) _ <- o -- c.f. T14546d. We have lost the location of the first statement in the GhcRn -> GhcTc + -> putSrcSpanDsA loc $ dsExpr e + | otherwise -> dsExpr e + -- Hpc Support HsTick tickish e -> do e' <- dsLExpr e ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -1997,10 +1997,12 @@ 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 app_lspan (fun, fun_lspan) larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho) +quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L arg_loc 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_arg, fun_lspan_arg), rn_args) <- splitHsApps arg + do { ((rn_fun_arg, fun_lspan_arg'), rn_args) <- splitHsApps arg + ; let fun_lspan_arg | null rn_args = locA arg_loc -- arg is an id (or an XExpr) so use the arg_loc in tcInstFun + | otherwise = fun_lspan_arg' -- Step 1: get the type of the head of the argument ; (fun_ue, mb_fun_ty) <- tcCollectingUsage $ tcInferAppHead_maybe rn_fun_arg @@ -2027,13 +2029,14 @@ quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L _ arg) sc_arg_ty@(Scaled _ ; ds_flag_arg <- getDeepSubsumptionFlag_DataConHead tc_fun_arg_head ; ((inst_args, app_res_rho), wanted) <- captureConstraints $ - tcInstFun do_ql True ds_flag_arg (arg_orig, rn_fun_arg, fun_lspan_arg) tc_fun_arg_head fun_sigma_arg_head rn_args + tcInstFun do_ql True ds_flag_arg (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] ; traceTc "quickLookArg 2" $ vcat [ text "arg:" <+> ppr arg + , text "orig:" <+> ppr arg_orig , text "orig_arg_rho:" <+> ppr orig_arg_rho , text "app_res_rho:" <+> ppr app_res_rho ] ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -404,11 +404,13 @@ tcDoStmts doExpr@(DoExpr _) ss@(L l stmts) res_ty then do { stmts' <- tcStmts (HsDoStmt doExpr) tcDoStmt stmts res_ty ; res_ty <- readExpType res_ty ; return (HsDo res_ty doExpr (L l stmts')) } - else do { expanded_expr <- expandDoStmts doExpr stmts -- Do expansion on the fly + else do { (L expr_lspan expanded_expr) <- expandDoStmts doExpr stmts -- Do expansion on the fly + ; traceTc "tcDoStmts" (vcat [ppr expr_lspan, ppr expanded_expr]) ; let orig = HsDo noExtField doExpr ss - ; addExpansionErrCtxt (OrigExpr orig) (srcCodeOriginErrCtxMsg (OrigExpr orig)) $ - do { e' <- tcMonoLExpr expanded_expr res_ty - ; return (mkExpandedExprTc orig (unLoc e'))} + ; mkExpandedExprTc orig <$> ( + setSrcSpanA expr_lspan $ -- We lose this expr_lspan location in GhcTc :( + addExpansionErrCtxt (OrigExpr orig) (srcCodeOriginErrCtxMsg (OrigExpr orig)) $ + tcExpr expanded_expr res_ty ) } } ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -1328,7 +1328,6 @@ setErrCtxt ctxt = updLclEnv (setLclEnvErrCtxt ctxt) -- | Add a fixed message to the error context. This message should not -- do any tidying. --- NB. No op in generated code -- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr addErrCtxt :: ErrCtxtMsg -> TcM a -> TcM a {-# INLINE addErrCtxt #-} -- Note [Inlining addErrCtxt] @@ -1339,7 +1338,6 @@ addExpansionErrCtxt :: SrcCodeOrigin -> ErrCtxtMsg -> TcM a -> TcM a addExpansionErrCtxt o msg = addExpansionErrCtxtM o (\env -> return (env, msg)) -- | Add a message to the error context. This message may do tidying. --- NB. No op in generated code -- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr addErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) -> TcM a -> TcM a {-# INLINE addErrCtxtM #-} -- Note [Inlining addErrCtxt] @@ -1363,16 +1361,10 @@ addLandmarkErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) -> TcM a -> TcM {-# INLINE addLandmarkErrCtxtM #-} -- Note [Inlining addErrCtxt] addLandmarkErrCtxtM ctxt = pushCtxt (MkErrCtxt LandmarkUserSrcCode ctxt) --- | NB. no op in generated code -- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr pushCtxt :: ErrCtxt -> TcM a -> TcM a {-# INLINE pushCtxt #-} -- Note [Inlining addErrCtxt] -pushCtxt ctxt = updLclEnv (updCtxt ctxt) - -updCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv --- Do not update the context if we are in generated code --- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr -updCtxt ctxt env = addLclEnvErrCtxt ctxt env +pushCtxt ctxt = updLclEnv (addLclEnvErrCtxt ctxt) popErrCtxt :: TcM a -> TcM a popErrCtxt thing_inside = updLclEnv (\env -> setLclEnvErrCtxt (pop $ getLclEnvErrCtxt env) env) $ ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -2460,7 +2460,7 @@ unifyTypeAndEmit t_or_k orig ty1 ty2 , u_given_eq_lvl = cur_lvl , u_rewriters = emptyCoHoleSet -- ToDo: check this , u_defer = ref, u_what = WU_None } - + ; traceTc "unifyTypeAndEmit" (ppr t_or_k) -- The hard work happens here ; co <- uType env ty1 ty2 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c2735328951f8b73e5f66f22246961f... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c2735328951f8b73e5f66f22246961f... You're receiving this email because of your account on gitlab.haskell.org.