[Git][ghc/ghc][wip/spj-apporv-Oct24] addThingCtxt in tcXExpr
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Mon Nov 4 14:42:30 UTC 2024
Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC
Commits:
9395bd29 by Apoorv Ingle at 2024-11-04T08:42:08-06:00
addThingCtxt in tcXExpr
- - - - -
5 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -898,7 +898,7 @@ instance Outputable HsThingRn where
OrigExpr x -> ppr_builder "<OrigExpr>:" x
OrigStmt x _ -> ppr_builder "<OrigStmt>:" x
OrigPat x _ -> ifPprDebug (braces (text "<OrigPat>:" <+> parens (ppr x))) (ppr x)
- where ppr_builder prefix x = ifPprDebug (braces (text prefix <+> parens (ppr x))) (ppr x)
+ where ppr_builder prefix x = ifPprDebug (braces (text prefix <+> parens (ppr x)))
instance Outputable XXExprGhcRn where
ppr (ExpandedThingRn o e) = ifPprDebug (braces $ vcat [ppr o, text ";;" , ppr e]) (ppr o)
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -402,14 +402,14 @@ tcApp rn_expr exp_res_ty
-- Step 2: Infer the type of `fun`, the head of the application
; (tc_fun, fun_sigma) <- tcInferAppHead fun
; let tc_head = (tc_fun, fun_ctxt)
-
+ ; traceTc "tcApp 1" (ppr rn_fun)
-- Step 3: Instantiate the function type (taking a quick look at args)
; do_ql <- wantQuickLook rn_fun
; (inst_args, app_res_rho)
<- setQLInstLevel do_ql $ -- See (TCAPP1) and (TCAPP2) in
-- Note [tcApp: typechecking applications]
tcInstFun do_ql True tc_head fun_sigma rn_args
-
+ ; traceTc "tcApp 2" (ppr rn_fun)
; case do_ql of
NoQL -> do { traceTc "tcApp:NoQL" (ppr rn_fun $$ ppr app_res_rho)
@@ -417,6 +417,7 @@ tcApp rn_expr exp_res_ty
-- See Note [Unify with expected type before typechecking arguments]
; res_wrap <- checkResultTy rn_expr tc_head inst_args
app_res_rho exp_res_ty
+ ; traceTc "tcApp valArgs" (ppr inst_args)
-- Step 4.2: typecheck the arguments
; tc_args <- tcValArgs NoQL inst_args
-- Step 4.3: wrap up
@@ -538,12 +539,7 @@ tcValArg do_ql (EValArg { ea_ctxt = ctxt
, ea_arg = larg@(L arg_loc arg)
, ea_arg_ty = sc_arg_ty })
= addArgCtxt ctxt larg $
- do { traceTc "tcValArg" $
- vcat [ ppr ctxt
- , text "arg type:" <+> ppr sc_arg_ty
- , text "arg:" <+> ppr larg ]
-
- -- Crucial step: expose QL results before checking exp_arg_ty
+ do { -- Crucial step: expose QL results before checking exp_arg_ty
-- So far as the paper is concerned, this step applies
-- the poly-substitution Theta, learned by QL, so that we
-- "see" the polymorphism in that argument type. E.g.
@@ -552,14 +548,21 @@ tcValArg do_ql (EValArg { ea_ctxt = ctxt
-- Then Theta = [p :-> forall a. a->a], and we want
-- to check 'e' with expected type (forall a. a->a)
-- See Note [Instantiation variables are short lived]
- ; Scaled mult exp_arg_ty <- case do_ql of
+ Scaled mult exp_arg_ty <- case do_ql of
DoQL -> liftZonkM $ zonkScaledTcType sc_arg_ty
NoQL -> return sc_arg_ty
+ ; traceTc "tcValArg {" $
+ vcat [ text "ctxt:" <+> ppr ctxt
+ , text "sigma_type" <+> ppr (mkCheckExpType exp_arg_ty)
+ , text "arg:" <+> ppr larg
+ ]
+
-- Now check the argument
; arg' <- tcScalingUsage mult $
tcPolyExpr arg (mkCheckExpType exp_arg_ty)
-
+ ; traceTc "tcValArg" $ vcat [ ppr arg'
+ , text "}" ]
; return (EValArg { ea_ctxt = ctxt
, ea_arg = L arg_loc arg'
, ea_arg_ty = noExtField }) }
@@ -897,6 +900,9 @@ addArgCtxt :: AppCtxt -> LHsExpr GhcRn
-- whether the piece of code is a `do`-expanded code or some other expanded code.
addArgCtxt ctxt (L arg_loc arg) thing_inside
= do { in_generated_code <- inGeneratedCode
+ ; traceTc "addArgCtxt" (vcat [ text "generated:" <+> ppr in_generated_code
+ , text "arg: " <+> ppr arg
+ , text "arg_loc" <+> ppr arg_loc])
; case ctxt of
VACall fun arg_no _ | not in_generated_code
-> do setSrcSpanA arg_loc $
=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -93,7 +93,7 @@ expand_do_stmts doFlavour (stmt@(L _loc (LetStmt _ bs)) : lstmts) =
-- See Note [Expanding HsDo with XXExprGhcRn] Equation (3) below
-- stmts ~~> stmts'
-- ------------------------------------------------
--- let x = e ; stmts ~~> let x = e in stmts'
+-- let x = e ; stmts ~~> let x = e in stmts'xo
do expand_stmts <- expand_do_stmts doFlavour lstmts
let expansion = genHsLet bs (genPopErrCtxtExpr expand_stmts)
return $ mkExpandedStmtAt stmt doFlavour expansion
@@ -575,5 +575,5 @@ mkExpandedStmtAt
-> HsDoFlavour -- ^ the flavour of the statement
-> HsExpr GhcRn -- ^ expanded expression
-> LHsExpr GhcRn -- ^ suitably wrapped located 'XXExprGhcRn'
-mkExpandedStmtAt oStmt@(L loc _) flav eExpr
- = L loc $ mkExpandedStmt oStmt flav eExpr
+mkExpandedStmtAt oStmt flav eExpr
+ = wrapGenSpan $ mkExpandedStmt oStmt flav eExpr
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -713,6 +713,10 @@ tcXExpr (PopErrCtxt (L loc e)) res_ty
= popErrCtxt $ -- See Part 3 of Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do`
setSrcSpanA loc $
tcExpr e res_ty
+
+tcXExpr (ExpandedThingRn o e) res_ty
+ = addThingCtxt o $
+ tcExpr e res_ty
{-
tcXExpr xe@(ExpandedThingRn o e') res_ty
| OrigStmt ls@(L loc s) flav <- o
@@ -734,8 +738,10 @@ tcXExpr xe@(ExpandedThingRn o e') res_ty
= setSrcSpanA loc $
mkExpandedStmtTc ls flav <$> tcApp (XExpr xe) res_ty
-}
+-- For record selection
tcXExpr xe res_ty = tcApp (XExpr xe) res_ty
+
{-
************************************************************************
* *
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -28,7 +28,7 @@ module GHC.Tc.Gen.Head
, nonBidirectionalErr
, pprArgInst
- , addHeadCtxt, addExprCtxt, addStmtCtxt, addFunResCtxt ) where
+ , addHeadCtxt, addThingCtxt, addExprCtxt, addStmtCtxt, addFunResCtxt ) where
import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckPolyExprNC, tcPolyLExprSig )
import {-# SOURCE #-} GHC.Tc.Gen.Splice( getUntypedSpliceBody )
@@ -1254,6 +1254,11 @@ mis-match in the number of value arguments.
* *
********************************************************************* -}
+addThingCtxt :: HsThingRn -> TcRn a -> TcRn a
+addThingCtxt (OrigExpr e) thing_inside = addExprCtxt e thing_inside
+addThingCtxt (OrigStmt (L loc stmt) flav) thing_inside = setSrcSpanA loc $ addStmtCtxt stmt flav $ setInGeneratedCode $ thing_inside
+addThingCtxt _ thing_inside = thing_inside
+
addStmtCtxt :: ExprStmt GhcRn -> HsDoFlavour -> TcRn a -> TcRn a
addStmtCtxt stmt flav thing_inside
= do let err_doc = pprStmtInCtxt (HsDoStmt flav) stmt
@@ -1269,7 +1274,7 @@ addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt e thing_inside
= case e of
HsUnboundVar {} -> thing_inside
- XExpr (PopErrCtxt (L _ e)) -> addExprCtxt e $ thing_inside
+ XExpr (PopErrCtxt (L loc e)) -> setSrcSpanA loc $ addExprCtxt e $ thing_inside
XExpr (ExpandedThingRn (OrigStmt stmt flav) _) -> addStmtCtxt (unLoc stmt) flav thing_inside
_ -> addErrCtxt (exprCtxt e) thing_inside
-- The HsUnboundVar special case addresses situations like
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9395bd297bc71a8ffc8e912536d12674b18c92c5
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9395bd297bc71a8ffc8e912536d12674b18c92c5
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20241104/891b9441/attachment-0001.html>
More information about the ghc-commits
mailing list