[Git][ghc/ghc][wip/expand-do] - addStmtCtxt to add the right statement context in the error contexts
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Fri Jun 16 18:39:10 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
29e94981 by Apoorv Ingle at 2023-06-16T13:38:03-05:00
- addStmtCtxt to add the right statement context in the error contexts
- expansion stmt to span over bind/>>= application and pattern rather than only the arguments
- - - - -
6 changed files:
- compiler/GHC/HsToCore/Expr.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/HsToCore/Expr.hs
=====================================
@@ -865,8 +865,7 @@ warnUnusedBindValue fun arg@(L loc _) arg_ty
, text "arg" <+> ppr arg
, text "arg_loc" <+> ppr loc
])
- when (isGeneratedSrcSpan l || isNoSrcSpan l -- it is compiler generated (>>)
- ) $
+ when (isGeneratedSrcSpan l) $ -- it is compiler generated (>>)
putSrcSpanDs (locA loc) $ warnDiscardedDoBindings arg arg_ty
where
-- Retrieve the location info and the head of the application
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -344,7 +344,8 @@ tcApp rn_expr exp_res_ty
; app_res_rho <- if do_ql
then quickLookResultType delta app_res_rho exp_res_ty
else return app_res_rho
- ; traceTc "tcApp1" empty
+ ; traceTc "tcApp1" (vcat [ text "tc_fun" <+> ppr tc_fun
+ , text "fun_sigma" <+> ppr fun_sigma ])
-- Unify with expected type from the context
-- See Note [Unify with expected type before typechecking arguments]
--
@@ -353,11 +354,13 @@ tcApp rn_expr exp_res_ty
-- the source program; it was added by the renamer. See
-- Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr
; let perhaps_add_res_ty_ctxt thing_inside
- | insideExpansion fun_ctxt
- = addHeadCtxt' fun_ctxt thing_inside
+ | insideExpansion fun_ctxt || isGeneratedSrcSpan (appCtxtLoc fun_ctxt)
+ = do traceTc "insideExpansion" (vcat [ppr rn_fun, ppr fun_ctxt])
+ addHeadCtxt fun_ctxt thing_inside
| otherwise
- = addFunResCtxt rn_fun rn_args app_res_rho exp_res_ty $
- thing_inside
+ = do traceTc "no expansion" (ppr rn_fun)
+ addFunResCtxt rn_fun rn_args app_res_rho exp_res_ty $
+ thing_inside
-- Match up app_res_rho: the result type of rn_expr
-- with exp_res_ty: the expected result type
@@ -531,7 +534,8 @@ tcInstFun :: Bool -- True <=> Do quick-look
-- modification in Fig 5, of the QL paper:
-- "A quick look at impredicativity" (ICFP'20).
tcInstFun do_ql inst_final (rn_fun, fun_ctxt) fun_sigma rn_args
- = do { traceTc "tcInstFun" (vcat [ ppr rn_fun, ppr fun_sigma
+ = do { traceTc "tcInstFun" (vcat [ ppr rn_fun, ppr fun_sigma, ppr fun_orig
+ , text "fun_ctxt" <+> ppr fun_ctxt
, text "args:" <+> ppr rn_args
, text "do_ql" <+> ppr do_ql ])
; go emptyVarSet [] [] fun_sigma rn_args }
@@ -593,7 +597,7 @@ tcInstFun do_ql inst_final (rn_fun, fun_ctxt) fun_sigma rn_args
-- E.g. #22908: f :: Foo => blah
-- No foralls! But if inst_final=False, don't instantiate
, not (null tvs && null theta)
- = do { (inst_tvs, wrap, fun_rho) <- addHeadCtxt' fun_ctxt $
+ = do { (inst_tvs, wrap, fun_rho) <- addHeadCtxt fun_ctxt $
instantiateSigma fun_orig tvs theta body2
-- addHeadCtxt: important for the class constraints
-- that may be emitted from instantiating fun_sigma
@@ -695,18 +699,35 @@ addArgCtxt :: AppCtxt -> LHsExpr GhcRn
--- See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr
addArgCtxt ctxt (L arg_loc arg) thing_inside
= do { in_generated_code <- inGeneratedCode
+ ; let in_src_ctxt = isGoodSrcSpan (appCtxtLoc ctxt)
+ ; traceTc "addArgCtxt" (vcat [ text "ctxt" <+> ppr ctxt
+ , text "arg" <+> ppr arg
+ , text "arg_loc" <+> ppr arg_loc
+ , text "is src ctxt" <+> ppr in_src_ctxt
+ , text "is generated code" <+> ppr in_generated_code
+ , text "is then" <+> ppr (is_then_fun (appCtxtExpr ctxt)) ])
; case ctxt of
- VACall fun arg_no _ | not in_generated_code
+ VACall fun _ _ | not in_src_ctxt
+ , is_then_fun fun || is_bind_fun fun
+ -> thing_inside -- do not do anything in case of expanded (>>)
+ -- TODO: this behaviour is not quite right
+ -- user written (>>)/(>>=) are infix and then 'expanded' to be prefix
+ VACall fun arg_no _ | not in_generated_code || not (is_then_fun fun || is_bind_fun fun)
-> setSrcSpanA arg_loc $
addErrCtxt (funAppCtxt fun arg arg_no) $
thing_inside
- VAExpansion _ _ | XExpr (PopSrcSpan (L loc (XExpr (ExpandedStmt (HsExpanded stmt _))))) <- arg
- -> setSrcSpanA loc $
- addErrCtxt (pprStmtInCtxt @Renamed @Renamed @Renamed (HsDoStmt (DoExpr Nothing)) (unLoc stmt)) $
- thing_inside
_ -> setSrcSpanA arg_loc $
addExprCtxt arg $ -- Auto-suppressed if arg_loc is generated
thing_inside }
+ where
+ is_then_fun :: HsExpr GhcRn -> Bool
+ is_then_fun (HsVar _ (L _ f)) = f `hasKey` thenMClassOpKey
+ is_then_fun _ = False
+
+ is_bind_fun :: HsExpr GhcRn -> Bool
+ is_bind_fun (HsVar _ (L _ f)) = f `hasKey` bindMClassOpKey
+ is_bind_fun _ = False
+
{- *********************************************************************
* *
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -209,16 +209,17 @@ 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 e)) res_ty
- = do popErrCtxt $ tcExpr (unLoc e) res_ty -- needs to do more intelligent popping
+tcExpr (XExpr (PopSrcSpan (L _ e))) res_ty
+ = do traceTc "tcExpr" (text "PopSrcSpan")
+ popErrCtxt $ tcExpr e res_ty
-tcExpr (XExpr (ExpandedStmt (HsExpanded stmt expr))) res_ty
+tcExpr (XExpr (ExpandedStmt (HsExpanded stmt@(L loc _) (L _ e)))) res_ty
= do { traceTc "tcDoStmts" (vcat [ text "stmt:" <+> ppr stmt
- , text "expr:" <+> ppr expr
+ , text "expr:" <+> ppr e
, text "res_ty:" <+> ppr res_ty
])
- ; addErrCtxt (pprStmtInCtxt @Renamed @Renamed @Renamed (HsDoStmt (DoExpr Nothing)) (unLoc stmt)) $
- tcExpr (unLoc expr) res_ty
+ ; setSrcSpanA loc $
+ addStmtCtxt stmt $ tcExpr e res_ty
}
@@ -428,21 +429,21 @@ tcExpr (HsMultiIf _ alts) res_ty
where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }
tcExpr hsDo@(HsDo _ doFlav@(DoExpr{}) (L _ stmts)) res_ty
- = do { expand_expr <- expandDoStmts doFlav stmts
+ = do { expanded_expr <- expandDoStmts doFlav stmts
-- Do expansion on the fly
- ; let expanded_do_expr = mkExpandedExpr hsDo (unLoc expand_expr)
+ ; let expanded_do_expr = mkExpandedExpr hsDo (unLoc expanded_expr)
; traceTc "tcDoStmts " (vcat [ text "hsDo:" <+> ppr hsDo
- , text "expr:" <+> ppr expand_expr
+ , text "expr:" <+> ppr expanded_expr
])
; tcExpr expanded_do_expr res_ty
}
tcExpr hsDo@(HsDo _ doFlav@(MDoExpr{}) (L _ stmts)) res_ty
- = do { expand_expr <- expandDoStmts doFlav stmts
+ = do { expanded_expr <- expandDoStmts doFlav stmts
-- Do expansion on the fly
- ; let expanded_do_expr = mkExpandedExpr hsDo (unLoc expand_expr)
+ ; let expanded_do_expr = mkExpandedExpr hsDo (unLoc expanded_expr)
; traceTc "tcDoStmts " (vcat [ text "hsDo:" <+> ppr hsDo
- , text "expr:" <+> ppr expand_expr
+ , text "expr:" <+> ppr expanded_expr
])
; tcExpr expanded_do_expr res_ty
}
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -18,7 +18,7 @@
module GHC.Tc.Gen.Head
( HsExprArg(..), EValArg(..), TcPass(..)
- , AppCtxt(..), appCtxtLoc, insideExpansion
+ , AppCtxt(..), appCtxtLoc, appCtxtExpr, insideExpansion
, splitHsApps, rebuildHsApps
, addArgWrap, isHsValArg
, countLeadingValArgs, isVisibleArg, pprHsExprArgTc
@@ -30,7 +30,7 @@ module GHC.Tc.Gen.Head
, tyConOf, tyConOfET, fieldNotInType
, nonBidirectionalErr
- , addHeadCtxt, addHeadCtxt', addExprCtxt, addFunResCtxt ) where
+ , addHeadCtxt, addExprCtxt, addStmtCtxt, addFunResCtxt ) where
import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckMonoExprNC, tcCheckPolyExprNC )
@@ -245,6 +245,10 @@ appCtxtLoc :: AppCtxt -> SrcSpan
appCtxtLoc (VAExpansion _ l) = l
appCtxtLoc (VACall _ _ l) = l
+appCtxtExpr :: AppCtxt -> HsExpr GhcRn
+appCtxtExpr (VAExpansion e _) = e
+appCtxtExpr (VACall e _ _) = e
+
insideExpansion :: AppCtxt -> Bool
insideExpansion (VAExpansion {}) = True
insideExpansion (VACall {}) = False
@@ -766,7 +770,7 @@ tcInferAppHead :: (HsExpr GhcRn, AppCtxt)
--
-- See Note [tcApp: typechecking applications] in GHC.Tc.Gen.App
tcInferAppHead (fun,ctxt) args
- = addHeadCtxt' ctxt $
+ = addHeadCtxt ctxt $
do { mb_tc_fun <- tcInferAppHead_maybe fun args
; case mb_tc_fun of
Just (fun', fun_sigma) -> return (fun', fun_sigma)
@@ -785,35 +789,21 @@ tcInferAppHead_maybe fun args
HsOverLit _ lit -> Just <$> tcInferOverLit lit
HsUntypedSplice (HsUntypedSpliceTop _ e) _
-> tcInferAppHead_maybe e args
- XExpr (PopSrcSpan e) -> tcInferAppHead_maybe (unLoc e) args
- XExpr (ExpandedStmt (HsExpanded _ e)) -> tcInferAppHead_maybe (unLoc e) args
+ -- XExpr (PopSrcSpan e) -> tcInferAppHead_maybe (unLoc e) args
+ -- XExpr (ExpandedStmt (HsExpanded _ e)) -> tcInferAppHead_maybe (unLoc e) args
_ -> return Nothing
addHeadCtxt :: AppCtxt -> TcM a -> TcM a
addHeadCtxt fun_ctxt thing_inside
| not (isGoodSrcSpan fun_loc) -- noSrcSpan => no arguments
- = thing_inside -- => context is already set
+ = do traceTc "addHeadCtxt not good" (ppr fun_ctxt)
+ thing_inside -- => context is already set
| otherwise
= setSrcSpan fun_loc $
- case fun_ctxt of
- VAExpansion orig _ -> addExprCtxt orig thing_inside
- VACall {} -> thing_inside
- where
- fun_loc = appCtxtLoc fun_ctxt
-
-addHeadCtxt' :: AppCtxt -> TcM a -> TcM a
-addHeadCtxt' fun_ctxt thing_inside
- | VAExpansion (HsDo _ doFlav (L _ (L loc stmt: _))) _ <- fun_ctxt -- the context is a do block, but set it as the first statement to obtain a more precise location of the error.
- = do setSrcSpan (locA loc) $
- addErrCtxt (pprStmtInCtxt @Renamed @Renamed @Renamed (HsDoStmt doFlav) stmt) $
- thing_inside
- | not (isGoodSrcSpan fun_loc) -- noSrcSpan => no arguments
- = thing_inside -- => context is already set
- | otherwise
- = setSrcSpan fun_loc $
- case fun_ctxt of
- VAExpansion orig _ -> addExprCtxt orig thing_inside
- VACall {} -> thing_inside
+ do traceTc "addHeadCtxt okay" (ppr fun_ctxt)
+ case fun_ctxt of
+ VAExpansion orig _ -> addExprCtxt orig thing_inside
+ VACall {} -> thing_inside
where
fun_loc = appCtxtLoc fun_ctxt
@@ -1483,11 +1473,15 @@ mis-match in the number of value arguments.
* *
********************************************************************* -}
+addStmtCtxt :: ExprLStmt GhcRn -> TcRn a -> TcRn a
+addStmtCtxt stmt thing_inside
+ = addErrCtxt ({-text "tcDoStmts" <+> -}
+ pprStmtInCtxt @Renamed @Renamed @Renamed (HsDoStmt (DoExpr Nothing)) (unLoc stmt)) thing_inside
+
addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt e thing_inside
= case e of
HsUnboundVar {} -> thing_inside
- XExpr (ExpandedStmt _) -> thing_inside
_ -> addErrCtxt (exprCtxt e) thing_inside
-- The HsUnboundVar special case addresses situations like
-- f x = _
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -1194,7 +1194,11 @@ genPopSrcSpanExpr = wrapGenSpan . mkPopSrcSpanExpr
-- mkExpandedStmtLExpr a b = noLocA $ mkExpandedStmt a b
expandDoStmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn)
-expandDoStmts = expand_do_stmts
+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
+ _ -> return expanded_expr
+
-- | Expand the Do statments so that it works fine with Quicklook
-- See Note[Rebindable Do and Expanding Statements]
@@ -1213,12 +1217,12 @@ expand_do_stmts _ (stmt@(L _ (ParStmt {})):_) =
-- See See Note [Monad Comprehensions]
pprPanic "expand_do_stmts: ParStmt" $ ppr stmt
-expand_do_stmts _ [stmt@(L loc (LastStmt _ body _ ret_expr))]
+expand_do_stmts _ [stmt@(L _ (LastStmt _ body _ ret_expr))]
-- last statement of a list comprehension, needs to explicitly return it
-- See `checkLastStmt` and `Syntax.Expr.StmtLR.LastStmt`
| NoSyntaxExprRn <- ret_expr
-- Last statement is just body if we are not in ListComp context. See Syntax.Expr.LastStmt
- = return $ L loc (mkExpandedStmt stmt body)
+ = return $ wrapGenSpan (mkExpandedStmt stmt body)
| SyntaxExprRn ret <- ret_expr
--
@@ -1228,14 +1232,14 @@ expand_do_stmts _ [stmt@(L loc (LastStmt _ body _ ret_expr))]
= return $ wrapGenSpan (mkExpandedStmt stmt (genHsApp (wrapGenSpan ret) body))
-expand_do_stmts do_or_lc ((L _ (LetStmt _ bs)) : lstmts) =
+expand_do_stmts do_or_lc (stmt@(L _ (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 $ genPopSrcSpanExpr (genHsLet bs expand_stmts)
+ return $ wrapGenSpan (mkExpandedStmt stmt (genHsLet bs $ genPopSrcSpanExpr expand_stmts))
-expand_do_stmts do_or_lc (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
+expand_do_stmts do_or_lc (stmt@(L _ (BindStmt xbsrn pat e)): lstmts)
| SyntaxExprRn bind_op <- xbsrn_bindOp xbsrn
, fail_op <- xbsrn_failOp xbsrn =
-- the pattern binding pat can fail
@@ -1247,22 +1251,25 @@ expand_do_stmts do_or_lc (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
do expand_stmts <- expand_do_stmts do_or_lc lstmts
expr@(L l _) <- mk_failable_lexpr_tcm pat expand_stmts fail_op
traceTc "expand_do_stmts" (vcat [ text "loc ex stmts" <+> ppr l])
- return $ (foldl genHsApp (wrapGenSpan bind_op) -- (>>=)
- [ L loc (mkPopSrcSpanExpr $ L loc (mkExpandedStmt stmt e))
- , expr
- ])
+ return $ wrapGenSpan (mkPopSrcSpanExpr $ wrapGenSpan (mkExpandedStmt stmt (
+ (wrapGenSpan bind_op) `genHsApp` e)) -- (>>=)
+ `genHsApp`
+ expr
+ )
| otherwise = pprPanic "expand do: shouldn't happen" (text "stmt" <+> ppr stmt)
-expand_do_stmts do_or_lc (stmt@(L loc (BodyStmt _ e (SyntaxExprRn f) _)) : lstmts) =
+expand_do_stmts do_or_lc (stmt@(L _ (BodyStmt _ e (SyntaxExprRn f) _)) : lstmts) =
-- See Note [BodyStmt]
-- stmts ~~> stmts'
-- ----------------------------------------------
-- e ; stmts ~~> (>>) e stmts'
do expand_stmts@(L l _) <- expand_do_stmts do_or_lc lstmts
traceTc "expand_do_stmts" (vcat [ text "loc ex stmts" <+> ppr l])
- return $ (foldl genHsApp (wrapGenSpan f) -- (>>)
- [ L loc (mkPopSrcSpanExpr $ L loc (mkExpandedStmt stmt e)) -- e
- , expand_stmts ]) -- stmts'
+ return $ wrapGenSpan (mkPopSrcSpanExpr $ wrapGenSpan (mkExpandedStmt stmt (
+ (wrapGenSpan f) -- (>>)
+ `genHsApp` e))
+ `genHsApp`
+ expand_stmts) -- stmts'
expand_do_stmts do_or_lc
((L do_loc (RecStmt { recS_stmts = L stmts_loc rec_stmts
@@ -1287,7 +1294,7 @@ expand_do_stmts do_or_lc
return $ mkHsApps (wrapGenSpan bind_fun) -- (>>=)
[ (wrapGenSpan mfix_fun) `mkHsApp` mfix_expr -- (mfix (do block))
, genHsLamDoExp [ mkBigLHsVarPatTup all_ids ] -- (\ x ->
- (genPopSrcSpanExpr expand_stmts) -- stmts')
+ ({-genPopSrcSpanExpr-} expand_stmts) -- stmts')
]
where
local_only_ids = local_ids \\ later_ids -- get unique local rec ids;
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -727,8 +727,8 @@ exprCtOrigin (HsUntypedSplice {}) = Shouldn'tHappenOrigin "TH untyped splice"
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 (L _ a))) = exprCtOrigin a
+exprCtOrigin (XExpr (ExpandedStmt {})) = DoOrigin
+exprCtOrigin (XExpr (PopSrcSpan {})) = Shouldn'tHappenOrigin "PopSrcSpan"
-- | Extract a suitable CtOrigin from a MatchGroup
matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/29e949819f36a7a46daaecb61d56fe4f672f33da
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/29e949819f36a7a46daaecb61d56fe4f672f33da
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/20230616/dc9fee56/attachment-0001.html>
More information about the ghc-commits
mailing list