[Git][ghc/ghc][wip/expand-do] - fix the location displayed for the errors that crop up during type checking LetStmt
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Thu Jul 13 00:03:03 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
da56d434 by Apoorv Ingle at 2023-07-12T19:01:36-05:00
- fix the location displayed for the errors that crop up during type checking LetStmt
- - - - -
7 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Types/Origin.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -459,15 +459,15 @@ data XXExprGhcRn
{-# UNPACK #-} !(HsExpansion (HsExpr GhcRn) (HsExpr GhcRn))
| ExpandedStmt
{-# UNPACK #-} !(HsExpansion (ExprLStmt GhcRn) (HsExpr GhcRn))
- | PopSrcSpan
+ | PopErrCtxt
{-# UNPACK #-} !(LHsExpr GhcRn)
-- Placeholder for identifying generated source locations in GhcRn phase
-- Should not presist post typechecking
-- Note [Expanding HsDo with HsExpansion] in GHC.Tc.Gen.Match
-- | Wrap a located expression with a PopSrcExpr
-mkPopSrcSpanExpr :: LHsExpr GhcRn -> HsExpr GhcRn
-mkPopSrcSpanExpr a = XExpr (PopSrcSpan a)
+mkPopErrCtxtExpr :: LHsExpr GhcRn -> HsExpr GhcRn
+mkPopErrCtxtExpr a = XExpr (PopErrCtxt a)
-- | Build a 'HsExpansion' out of an extension constructor,
-- and the two components of the expansion: original and
@@ -753,7 +753,7 @@ ppr_expr (XExpr x) = case ghcPass @p of
instance Outputable XXExprGhcRn where
ppr (ExpandedExpr ex) = whenPprDebug (text "[ExpandedExpr]") <+> ppr ex
ppr (ExpandedStmt ex) = whenPprDebug (text "[ExpandedStmt]") <+> ppr ex
- ppr (PopSrcSpan e) = whenPprDebug (text "<PopSrcSpan>") <+> parens (ppr e)
+ ppr (PopErrCtxt e) = whenPprDebug (text "<PopSrcSpan>") <+> parens (ppr e)
instance Outputable XXExprGhcTc where
ppr (WrapExpr (HsWrap co_fn e))
@@ -801,7 +801,7 @@ ppr_infix_expr _ = Nothing
ppr_infix_expr_rn :: XXExprGhcRn -> Maybe SDoc
ppr_infix_expr_rn (ExpandedExpr (HsExpanded a _)) = ppr_infix_expr a
ppr_infix_expr_rn (ExpandedStmt _) = Nothing
-ppr_infix_expr_rn (PopSrcSpan (L _ a)) = ppr_infix_expr a
+ppr_infix_expr_rn (PopErrCtxt (L _ a)) = ppr_infix_expr a
ppr_infix_expr_tc :: XXExprGhcTc -> Maybe SDoc
ppr_infix_expr_tc (WrapExpr (HsWrap _ e)) = ppr_infix_expr e
@@ -914,7 +914,7 @@ hsExprNeedsParens prec = go
go_x_rn :: XXExprGhcRn -> Bool
go_x_rn (ExpandedExpr (HsExpanded a _)) = hsExprNeedsParens prec a
go_x_rn (ExpandedStmt _) = False
- go_x_rn (PopSrcSpan (L _ a)) = hsExprNeedsParens prec a
+ go_x_rn (PopErrCtxt (L _ a)) = hsExprNeedsParens prec a
-- | Parenthesize an expression without token information
@@ -960,7 +960,7 @@ isAtomicHsExpr (XExpr x)
go_x_rn :: XXExprGhcRn -> Bool
go_x_rn (ExpandedExpr (HsExpanded a _)) = isAtomicHsExpr a
go_x_rn (ExpandedStmt _) = False
- go_x_rn (PopSrcSpan (L _ a)) = isAtomicHsExpr a
+ go_x_rn (PopErrCtxt (L _ a)) = isAtomicHsExpr a
isAtomicHsExpr _ = False
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -1671,7 +1671,7 @@ repE (XExpr (ExpandedExpr (HsExpanded orig_expr ds_expr)))
; if rebindable_on -- See Note [Quotation and rebindable syntax]
then repE ds_expr
else repE orig_expr }
-repE (XExpr (PopSrcSpan (L _ e))) = repE e
+repE (XExpr (PopErrCtxt (L _ e))) = repE e
repE e@(XExpr (ExpandedStmt _)) = notHandled (ThExpressionForm e)
repE e@(HsPragE _ (HsPragSCC {}) _) = notHandled (ThCostCentres e)
repE e@(HsTypedBracket{}) = notHandled (ThExpressionForm e)
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -321,6 +321,8 @@ The latter is much better. That is why we call unifyExpectedType
before tcValArgs.
-}
+
+
tcApp :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
-- See Note [tcApp: typechecking applications]
tcApp rn_expr exp_res_ty
@@ -360,6 +362,11 @@ tcApp rn_expr exp_res_ty
= do traceTc "tcApp" (vcat [text "VACall stmt", ppr stmt, ppr loc, ppr rn_fun, ppr fun_ctxt])
setSrcSpanA loc $ -- addStmtCtxt (text "tcApp VACall stmt") stmt
thing_inside
+ | insideExpansion fun_ctxt
+ , VAExpansionStmt stmt@(L loc _) <- fun_ctxt
+ = do traceTc "tcApp" (vcat [text "VAExpansionStmt", ppr stmt, ppr loc, ppr rn_fun, ppr fun_ctxt])
+ setSrcSpanA loc $ addStmtCtxt (text "tcApp VAExpansionStmt") stmt
+ thing_inside
| XExpr (ExpandedStmt (HsExpanded stmt@(L loc _) _)) <- rn_fun
= do traceTc "tcApp" (vcat [text "VAExpansion stmt", ppr stmt, ppr loc, ppr rn_fun, ppr fun_ctxt])
setSrcSpanA loc $ -- addStmtCtxt (text "tcApp VAExpansion stmt") stmt
@@ -724,6 +731,11 @@ addArgCtxt ctxt (L arg_loc arg) thing_inside
-- <+> ppr (is_bind_fun (appCtxtExpr ctxt))
])
; case ctxt of
+ VACall (XExpr (ExpandedStmt (HsExpanded stmt@(L loc _) _))) _ _
+ -> do traceTc "addArgCtxt 2c" empty -- Set the context "In the stmt .."
+ setSrcSpanA loc $
+ addStmtCtxt (text "addArgCtxt 2c") stmt $
+ thing_inside
VACall fun arg_no _ | not in_generated_code && not (is_then_fun fun || is_bind_fun fun)
-> do traceTc "addArgCtxt 2a" empty
setSrcSpanA arg_loc $
@@ -732,11 +744,6 @@ addArgCtxt ctxt (L arg_loc arg) thing_inside
VACall fun _ _ | not in_generated_code && is_then_fun fun
-> do traceTc "addArgCtxt 2b >>" empty -- Skip setting "In the expression..." if the arg_no is > 1
thing_inside
- VACall (XExpr (ExpandedStmt (HsExpanded stmt@(L loc _) _))) _ _
- -> do traceTc "addArgCtxt 2c" empty -- Set the context "In the stmt .."
- setSrcSpanA loc $
- addStmtCtxt (text "addArgCtxt 2c") stmt $
- thing_inside
VAExpansion (HsDo _ _ _) _
-> do traceTc "addArgCtxt 2d" empty -- Set the context as the first statement of do block
-- setSrcSpanA arg_loc $ -- skip adding "In the expression do ... "
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -211,9 +211,9 @@ tcExpr e@(ExprWithTySig {}) res_ty = tcApp e res_ty
tcExpr e@(HsRecSel {}) res_ty = tcApp e res_ty
tcExpr e@(XExpr (ExpandedExpr {})) res_ty = tcApp e res_ty
-tcExpr (XExpr (PopSrcSpan (L _ e))) res_ty
- = do traceTc "tcExpr" (text "PopSrcSpan")
- popErrCtxt $ tcExpr e res_ty
+tcExpr (XExpr (PopErrCtxt (L loc e))) res_ty
+ = do traceTc "tcExpr" (text "PopErrCtxt")
+ popErrCtxt $ setSrcSpanA loc $ tcApp e res_ty
tcExpr (XExpr (ExpandedStmt (HsExpanded stmt@(L loc _) e))) res_ty
= do { traceTc "tcDoStmts" (vcat [ text "stmt:" <+> ppr stmt
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -296,8 +296,22 @@ splitHsApps :: HsExpr GhcRn
-> ( (HsExpr GhcRn, AppCtxt) -- Head
, [HsExprArg 'TcpRn]) -- Args
-- See Note [splitHsApps]
-splitHsApps e = go e (top_ctxt 0 e) []
+splitHsApps e = maybeShiftCtxt $
+ go e (top_ctxt 0 e) []
where
+ -- Ugly fix for setting the correct AppCtxt for let statements
+ -- The point is that when we try to typecheck a let expression we are checking
+ -- for the body of the let expression. But the go function for let statement expansion does not
+ -- calculate the correct app context
+ maybeShiftCtxt :: ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn]) -> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
+ maybeShiftCtxt ((rn_fun, fun_ctxt), rn_args)
+ | ((HsLet _ _ _ _ (L _ (XExpr (PopErrCtxt
+ (L _ (XExpr (ExpandedStmt (HsExpanded body_stmt _))))))))
+ , VAExpansionStmt{}) <- (rn_fun, fun_ctxt)
+ = ((rn_fun, VAExpansionStmt body_stmt), rn_args)
+ | otherwise = ((rn_fun, fun_ctxt), rn_args)
+
+
top_ctxt :: Int -> HsExpr GhcRn -> AppCtxt
-- Always returns VACall fun n_val_args noSrcSpan
-- to initialise the argument splitting in 'go'
@@ -307,7 +321,6 @@ splitHsApps e = go e (top_ctxt 0 e) []
top_ctxt n (HsAppType _ fun _ _) = top_lctxt (n+1) fun
top_ctxt n (HsApp _ fun _) = top_lctxt (n+1) fun
top_ctxt n (XExpr (ExpandedExpr (HsExpanded orig _))) = VACall orig n noSrcSpan
- -- top_ctxt n (XExpr (ExpandedStmt (HsExpanded stmt _))) = VACall other_fun n generatedSrcSpan
top_ctxt n other_fun = VACall other_fun n noSrcSpan
top_lctxt n (L _ fun) = top_ctxt n fun
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -1190,7 +1190,7 @@ checkArgCounts matchContext (MG { mg_alts = L _ (match1:matches) })
-- | Generated location for PopSrcExpr
-- genPopSrcSpanExpr :: LHsExpr GhcRn -> LHsExpr GhcRn
--- genPopSrcSpanExpr = wrapGenSpan . mkPopSrcSpanExpr
+-- genPopSrcSpanExpr = wrapGenSpan . mkPopErrCtxtExpr
-- mkExpandedStmtLExpr
-- :: ExprLStmt GhcRn -- ^ source statement
@@ -1202,7 +1202,7 @@ expandDoStmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn)
-- TODO ANI: maybe better to not add the Pop error contexts in the first place?
expandDoStmts doFlav stmts = do expanded_expr <- expand_do_stmts doFlav stmts
case expanded_expr of
- L _ (XExpr (PopSrcSpan (L loc e))) -> return $ L loc e
+ L _ (XExpr (PopErrCtxt (L loc e))) -> return $ L loc e
_ -> return expanded_expr
-- | Expand the Do statments so that it works fine with Quicklook
@@ -1229,7 +1229,7 @@ expand_do_stmts _ [stmt@(L loc (LastStmt _ body _ ret_expr))]
| NoSyntaxExprRn <- ret_expr
-- Last statement is just body if we are not in ListComp context. See Syntax.Expr.LastStmt
= do traceTc "expand_do_stmts last" (ppr ret_expr)
- return $ L loc (mkPopSrcSpanExpr $ L loc (mkExpandedStmt stmt (unLoc body)))
+ return $ L loc (mkPopErrCtxtExpr $ L loc (mkExpandedStmt stmt (unLoc body)))
| SyntaxExprRn ret <- ret_expr
--
@@ -1237,19 +1237,19 @@ expand_do_stmts _ [stmt@(L loc (LastStmt _ body _ ret_expr))]
-- return e ~~> return e
-- to make T18324 work
= do traceTc "expand_do_stmts last" (ppr ret_expr)
- return $ wrapGenSpan (mkPopSrcSpanExpr $
- wrapGenSpan (mkExpandedStmt stmt (
+ return $ wrapGenSpan (mkPopErrCtxtExpr $
+ L loc (mkExpandedStmt stmt (
genHsApp (wrapGenSpan ret) body)))
-expand_do_stmts do_or_lc (stmt@(L _ (LetStmt _ bs)) : lstmts) =
+expand_do_stmts do_or_lc (stmt@(L loc (LetStmt _ bs)) : lstmts) =
-- stmts ~~> stmts'
-- ------------------------------------------------
-- let x = e ; stmts ~~> let x = e in stmts'
do expand_stmts <- expand_do_stmts do_or_lc lstmts
- return $ wrapGenSpan (mkPopSrcSpanExpr $ wrapGenSpan (mkExpandedStmt stmt (genHsLet bs $ expand_stmts)))
+ return $ wrapGenSpan (mkPopErrCtxtExpr $ L loc (mkExpandedStmt stmt (genHsLet bs $ expand_stmts)))
-expand_do_stmts do_or_lc (stmt@(L _ (BindStmt xbsrn pat e)): lstmts)
+expand_do_stmts do_or_lc (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
| SyntaxExprRn bind_op <- xbsrn_bindOp xbsrn
, fail_op <- xbsrn_failOp xbsrn =
-- the pattern binding pat can fail
@@ -1262,7 +1262,7 @@ expand_do_stmts do_or_lc (stmt@(L _ (BindStmt xbsrn pat e)): lstmts)
-- let spanWrap = if isRebindableOn then noLocA else wrapGenSpan
expand_stmts <- expand_do_stmts do_or_lc lstmts
expr <- mk_failable_lexpr_tcm pat expand_stmts fail_op
- return $ wrapGenSpan (mkPopSrcSpanExpr $ wrapGenSpan (wrapGenSpan (mkExpandedStmt stmt (
+ return $ wrapGenSpan (mkPopErrCtxtExpr $ L loc (wrapGenSpan (mkExpandedStmt stmt (
(wrapGenSpan bind_op) -- (>>=)
`genHsApp` e))
`genHsApp`
@@ -1277,7 +1277,7 @@ expand_do_stmts do_or_lc (stmt@(L loc (BodyStmt _ e (SyntaxExprRn then_op) _)) :
do -- isRebindableOn <- xoptM LangExt.RebindableSyntax
-- let spanWrap = if isRebindableOn then noLocA else wrapGenSpan
expand_stmts <- expand_do_stmts do_or_lc lstmts
- return $ wrapGenSpan (mkPopSrcSpanExpr $ L loc ((L loc (mkExpandedStmt stmt (
+ return $ wrapGenSpan (mkPopErrCtxtExpr $ L loc ((L loc (mkExpandedStmt stmt (
(wrapGenSpan then_op) -- (>>)
`genHsApp` e)))
`genHsApp`
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -728,7 +728,7 @@ exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc"
exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression"
exprCtOrigin (XExpr (ExpandedExpr (HsExpanded a _))) = exprCtOrigin a
exprCtOrigin (XExpr (ExpandedStmt {})) = DoOrigin
-exprCtOrigin (XExpr (PopSrcSpan {})) = Shouldn'tHappenOrigin "PopSrcSpan"
+exprCtOrigin (XExpr (PopErrCtxt {})) = Shouldn'tHappenOrigin "PopErrCtxt"
-- | Extract a suitable CtOrigin from a MatchGroup
matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/da56d43443f3667bbf7f3394b262964c27fb1f8e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/da56d43443f3667bbf7f3394b262964c27fb1f8e
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/20230712/1f8f010d/attachment-0001.html>
More information about the ghc-commits
mailing list