[Git][ghc/ghc][wip/spj-apporv-Oct24] remove adhoc addthingCtxt and remove location from PopErrCtxt HsExprs
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Tue Nov 26 08:35:23 UTC 2024
Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC
Commits:
3f5c3ae5 by Apoorv Ingle at 2024-11-26T00:34:32-08:00
remove adhoc addthingCtxt and remove location from PopErrCtxt HsExprs
- - - - -
6 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Quote.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
=====================================
@@ -548,7 +548,7 @@ data XXExprGhcRn
}
| PopErrCtxt -- A hint for typechecker to pop
- {-# UNPACK #-} !(LHsExpr GhcRn) -- the top of the error context stack
+ {-# UNPACK #-} !(HsExpr GhcRn) -- the top of the error context stack
-- Does not presist post renaming phase
-- See Part 3. of Note [Expanding HsDo with XXExprGhcRn]
-- in `GHC.Tc.Gen.Do`
@@ -945,7 +945,7 @@ ppr_infix_expr _ = Nothing
ppr_infix_expr_rn :: XXExprGhcRn -> Maybe SDoc
ppr_infix_expr_rn (ExpandedThingRn thing _) = ppr_infix_hs_expansion thing
-ppr_infix_expr_rn (PopErrCtxt (L _ a)) = ppr_infix_expr a
+ppr_infix_expr_rn (PopErrCtxt a) = ppr_infix_expr a
ppr_infix_expr_rn (HsRecSelRn f) = Just (pprInfixOcc f)
ppr_infix_expr_tc :: XXExprGhcTc -> Maybe SDoc
@@ -1062,7 +1062,7 @@ hsExprNeedsParens prec = go
go_x_rn :: XXExprGhcRn -> Bool
go_x_rn (ExpandedThingRn thing _ ) = hsExpandedNeedsParens thing
- go_x_rn (PopErrCtxt (L _ a)) = hsExprNeedsParens prec a
+ go_x_rn (PopErrCtxt a) = hsExprNeedsParens prec a
go_x_rn (HsRecSelRn{}) = False
hsExpandedNeedsParens :: HsThingRn -> Bool
@@ -1114,9 +1114,9 @@ isAtomicHsExpr (XExpr x)
go_x_tc (HsRecSelTc{}) = True
go_x_rn :: XXExprGhcRn -> Bool
- go_x_rn (ExpandedThingRn thing _) = isAtomicExpandedThingRn thing
- go_x_rn (PopErrCtxt (L _ a)) = isAtomicHsExpr a
- go_x_rn (HsRecSelRn{}) = True
+ go_x_rn (ExpandedThingRn thing _) = isAtomicExpandedThingRn thing
+ go_x_rn (PopErrCtxt a) = isAtomicHsExpr a
+ go_x_rn (HsRecSelRn{}) = True
isAtomicExpandedThingRn :: HsThingRn -> Bool
isAtomicExpandedThingRn (OrigExpr e) = isAtomicHsExpr e
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -1717,7 +1717,7 @@ repE e@(XExpr (ExpandedThingRn o x))
| otherwise
= notHandled (ThExpressionForm e)
-repE (XExpr (PopErrCtxt (L _ e))) = repE e
+repE (XExpr (PopErrCtxt e)) = repE e
repE (XExpr (HsRecSelRn (FieldOcc _ (L _ x)))) = repE (HsVar noExtField (noLocA x))
repE e@(HsPragE _ (HsPragSCC {}) _) = notHandled (ThCostCentres e)
=====================================
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,7 +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
=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -95,7 +95,7 @@ expand_do_stmts doFlavour (stmt@(L _ (LetStmt _ bs)) : lstmts) =
-- ------------------------------------------------
-- 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)
+ let expansion = genHsLet bs (genPopErrCtxtExpr . unLoc $ expand_stmts)
return $ mkExpandedStmtAt (noAnnSrcSpan generatedSrcSpan) stmt doFlavour expansion
expand_do_stmts doFlavour (stmt@(L _loc (BindStmt xbsrn pat e)): lstmts)
@@ -108,7 +108,7 @@ expand_do_stmts doFlavour (stmt@(L _loc (BindStmt xbsrn pat e)): lstmts)
-- -------------------------------------------------------
-- pat <- e ; stmts ~~> (>>=) e f
= do expand_stmts <- expand_do_stmts doFlavour lstmts
- failable_expr <- mk_failable_expr doFlavour pat (genPopErrCtxtExpr expand_stmts) fail_op
+ failable_expr <- mk_failable_expr doFlavour pat (genPopErrCtxtExpr . unLoc $ expand_stmts) fail_op
let expansion = genHsExpApps bind_op -- (>>=)
[ e
, failable_expr ]
@@ -126,7 +126,7 @@ expand_do_stmts doFlavour (stmt@(L _loc (BodyStmt _ e (SyntaxExprRn then_op) _))
do expand_stmts_expr <- expand_do_stmts doFlavour lstmts
let expansion = genHsExpApps then_op -- (>>)
[ e
- , genPopErrCtxtExpr expand_stmts_expr ]
+ , genPopErrCtxtExpr . unLoc $ expand_stmts_expr ]
return $ mkExpandedStmtAt (noAnnSrcSpan generatedSrcSpan) stmt doFlavour expansion
expand_do_stmts doFlavour
@@ -561,10 +561,10 @@ It stores the original statement (with location) and the expanded expression
-- | Wrap a located expression with a `PopErrCtxt`
-mkPopErrCtxtExpr :: LHsExpr GhcRn -> HsExpr GhcRn
+mkPopErrCtxtExpr :: HsExpr GhcRn -> HsExpr GhcRn
mkPopErrCtxtExpr a = XExpr (PopErrCtxt a)
-genPopErrCtxtExpr :: LHsExpr GhcRn -> LHsExpr GhcRn
+genPopErrCtxtExpr :: HsExpr GhcRn -> LHsExpr GhcRn
genPopErrCtxtExpr a = wrapGenSpan $ mkPopErrCtxtExpr a
-- | Build an expression using the extension constructor `XExpr`,
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -709,35 +709,14 @@ tcExpr (SectionR {}) ty = pprPanic "tcExpr:SectionR" (ppr ty)
tcXExpr :: XXExprGhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
-tcXExpr (PopErrCtxt (L loc e)) res_ty
+tcXExpr (PopErrCtxt 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@(OrigStmt stmt flav) e) res_ty
= addThingCtxt o $
- mkExpandedStmtTc stmt flav <$> tcExpr e res_ty
-{-
-tcXExpr xe@(ExpandedThingRn o e') res_ty
- | OrigStmt ls@(L loc s) flav <- o
- , HsLet x binds e <- e'
- = do { (binds', e') <- setSrcSpanA loc $
- addStmtCtxt s flav $
- tcLocalBinds binds $
- tcMonoExprNC e res_ty -- NB: Do not call tcMonoExpr here as it adds
- -- a duplicate error context
- ; return $ mkExpandedStmtTc ls flav (HsLet x binds' e')
- }
-
- | OrigStmt s@(L loc LastStmt{}) flav <- o
- = setSrcSpanA loc $
- addStmtCtxt (unLoc s) flav $
- mkExpandedStmtTc s flav <$> tcApp e' res_ty
+ mkExpandedStmtTc stmt flav <$> tcExpr e res_ty
- | OrigStmt ls@(L loc _) flav <- o
- = 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
=====================================
@@ -555,10 +555,6 @@ tcInferAppHead_maybe fun
_ -> return Nothing
addHeadCtxt :: AppCtxt -> TcM a -> TcM a
-addHeadCtxt (VAExpansion (OrigStmt (L loc stmt) flav) _ _) thing_inside =
- do setSrcSpanA loc $
- addStmtCtxt stmt flav
- thing_inside
addHeadCtxt fun_ctxt thing_inside
| not (isGoodSrcSpan fun_loc) -- noSrcSpan => no arguments
= thing_inside -- => context is already set
@@ -1255,15 +1251,12 @@ 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 = do
- gen <- inGeneratedCode
- if gen
- then setSrcSpanA loc $ addStmtCtxt stmt flav $ setInGeneratedCode $ thing_inside
- -- If we are in generated code, we need to set the error context at the correct
- -- location and then switch context back into generated code to do the thing_inside
- -- See Note [Rebindable syntax and XXExprGhcRn]
- else addStmtCtxt stmt flav $ thing_inside
+ setSrcSpanA loc $
+ addStmtCtxt stmt flav $
+ thing_inside
+-- addThingCtxt (OrigExpr e) thing_inside = addExprCtxt e thing_inside
addThingCtxt _ thing_inside = thing_inside
addStmtCtxt :: ExprStmt GhcRn -> HsDoFlavour -> TcRn a -> TcRn a
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3f5c3ae5dba3f20abd7160a1986f478337caec42
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3f5c3ae5dba3f20abd7160a1986f478337caec42
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/20241126/2ab41a50/attachment-0001.html>
More information about the ghc-commits
mailing list