[Git][ghc/ghc][wip/expand-do] 2 commits: add a more appropriate error context for case alternative in failable do stmt pattern binding
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Mon May 29 23:43:41 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
83605216 by Apoorv Ingle at 2023-05-26T19:42:38-05:00
add a more appropriate error context for case alternative in failable do stmt pattern binding
- - - - -
ecdb4bd6 by Apoorv Ingle at 2023-05-29T18:43:31-05:00
more error context changes
- - - - -
3 changed files:
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Match.hs
Changes:
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -41,7 +41,7 @@ just attach noSrcSpan to everything.
module GHC.Hs.Utils(
-- * Terms
mkHsPar, mkHsApp, mkHsAppWith, mkHsApps, mkHsAppsWith,
- mkHsAppType, mkHsAppTypes, mkHsCaseAlt,
+ mkHsAppType, mkHsAppTypes, mkHsCaseAlt, mkHsCaseAltDoExp,
mkSimpleMatch, unguardedGRHSs, unguardedRHS,
mkMatchGroup, mkLamCaseMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf,
mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,
@@ -282,7 +282,7 @@ mkHsLamDoExp :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin)
mkHsLamDoExp pats body = mkHsPar (noLocA $ HsLam noExtField matches)
where
matches = mkMatchGroup (Generated DoExpansion)
- (noLocA [mkSimpleMatch LambdaExpr pats' body])
+ (noLocA [mkSimpleMatch (StmtCtxt (HsDoStmt (DoExpr Nothing))) pats' body])
pats' = map (parenthesizePat appPrec) pats
mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc
@@ -300,6 +300,17 @@ mkHsCaseAlt :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
mkHsCaseAlt pat expr
= mkSimpleMatch CaseAlt [pat] expr
+
+mkHsCaseAltDoExp :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
+ ~ SrcAnn NoEpAnns,
+ Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
+ ~ SrcSpanAnnA)
+ => LPat (GhcPass p) -> (LocatedA (body (GhcPass p)))
+ -> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
+mkHsCaseAltDoExp pat expr
+ = mkSimpleMatch (StmtCtxt (HsDoStmt (DoExpr Nothing))) [pat] expr
+
+
nlHsTyApp :: Id -> [Type] -> LHsExpr GhcTc
nlHsTyApp fun_id tys
= noLocA (mkHsWrap (mkWpTyApps tys) (HsVar noExtField (noLocA fun_id)))
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -269,7 +269,9 @@ tcExpr (HsLam _ match) res_ty
where
match_ctxt = MC { mc_what = case mg_ext match of
Generated DoExpansion -> StmtCtxt (HsDoStmt (DoExpr Nothing))
+ -- Either this lambda expr was generated by expanding a do block
_ -> LambdaExpr
+ -- Or it was a true lambda
, mc_body = tcBody }
herald = ExpectedFunTyLam match
@@ -416,9 +418,10 @@ tcExpr (HsMultiIf _ alts) res_ty
tcExpr (XExpr (ExpandedStmt (HsExpanded stmt expr))) res_ty
= do { traceTc "tcDoStmts" (vcat [ text "stmt:" <+> ppr stmt
, text "expr:" <+> ppr expr
- , text "res_ty" <+> ppr res_ty ])
+ , text "res_ty" <+> ppr res_ty
+ ])
; addErrCtxt (pprStmtInCtxt @Renamed @Renamed @Renamed (HsDoStmt (DoExpr Nothing)) (unLoc stmt)) $
- tcExpr (unLoc expr) res_ty
+ tcApp (unLoc expr) res_ty
}
tcExpr hsDo@(HsDo _ doFlav@(DoExpr{}) (L _ stmts)) res_ty
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -267,6 +267,7 @@ tcMatch ctxt pat_tys rhs_ty match
add_match_ctxt match thing_inside
= case mc_what ctxt of
LambdaExpr -> thing_inside
+ StmtCtxt (HsDoStmt{}) -> thing_inside -- this is an expanded do stmt
_ -> addErrCtxt (pprMatchInCtxt match) thing_inside
-------------
@@ -1249,11 +1250,11 @@ expand_do_stmts do_or_lc (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
-- -------------------------------------------------------
-- pat <- e ; stmts ~~> (>>=) e f
do expand_stmts <- expand_do_stmts do_or_lc lstmts
- expr <- mk_failable_lexpr_tcm pat expand_stmts fail_op
- return $ mkHsApps (wrapGenSpan bind_op) -- (>>=)
- [ genPopSrcSpanExpr $ L loc (mkExpandedStmt stmt e)
- , expr
- ]
+ expr <- mk_failable_lexpr_tcm pat (noLocA $ mkExpandedStmt stmt expand_stmts) fail_op
+ return $ (mkHsApps (wrapGenSpan bind_op) -- (>>=)
+ [ genPopSrcSpanExpr $ L loc (mkExpandedStmt stmt e)
+ , genPopSrcSpanExpr expr
+ ])
| otherwise = pprPanic "expand do: shouldn't happen" (text "stmt" <+> ppr stmt)
@@ -1339,10 +1340,14 @@ expand_do_stmts do_or_lc ((L _ (ApplicativeStmt _ args mb_join)): lstmts) =
}
where
do_arg :: ApplicativeArg GhcRn -> TcM ((LPat GhcRn, FailOperator GhcRn), LHsExpr GhcRn)
- do_arg (ApplicativeArgOne mb_fail_op pat expr _) =
- return ((pat, mb_fail_op), expr)
- do_arg (ApplicativeArgMany _ stmts ret pat _) =
- do { expr <- expand_do_stmts do_or_lc $ stmts ++ [wrapGenSpan $ mkLastStmt (wrapGenSpan ret)]
+ do_arg (ApplicativeArgOne
+ { xarg_app_arg_one = mb_fail_op
+ , app_arg_pattern = pat@(L loc _)
+ , arg_expr = rhs
+ }) =
+ return ((pat, mb_fail_op), wrapGenSpan (mkExpandedStmt (L loc (BindStmt xbsn pat rhs)) rhs))
+ do_arg (ApplicativeArgMany _ stmts ret pat ctxt) =
+ do { expr <- expand_do_stmts ctxt $ stmts ++ [wrapGenSpan $ mkLastStmt (wrapGenSpan ret)]
; return ((pat, Nothing), expr) }
match_args :: (LPat GhcRn, FailOperator GhcRn) -> LHsExpr GhcRn -> TcM (LHsExpr GhcRn)
@@ -1353,6 +1358,9 @@ expand_do_stmts do_or_lc ((L _ (ApplicativeStmt _ args mb_join)): lstmts) =
SyntaxExprRn op -> mkHsApps (wrapGenSpan op) [l_expr, r_expr]
NoSyntaxExprRn -> pprPanic "expand_do_stmts op:" (ppr op)
+ xbsn :: XBindStmtRn
+ xbsn = XBindStmtRn NoSyntaxExprRn Nothing
+
expand_do_stmts _ stmts = pprPanic "expand_do_stmts: impossible happened" $ (ppr stmts)
@@ -1374,7 +1382,7 @@ mk_failable_lexpr_tcm pat lexpr fail_op =
; if irrf_pat
-- don't decorate with fail statement if
-- the pattern is irrefutable
- then return $ mkHsLamDoExp [pat] (genPopSrcSpanExpr lexpr)
+ then return $ mkHsLamDoExp [pat] lexpr
else mk_fail_lexpr pat lexpr fail_op
}
@@ -1385,9 +1393,9 @@ mk_fail_lexpr :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsEx
mk_fail_lexpr pat lexpr (Just (SyntaxExprRn fail_op)) =
do dflags <- getDynFlags
return $ wrapGenSpan (HsLam noExtField $ mkMatchGroup (Generated DoExpansion) -- \
- (wrapGenSpan [ mkHsCaseAlt pat (genPopSrcSpanExpr lexpr) -- pat -> expr
- , mkHsCaseAlt nlWildPatName -- _ -> fail "fail pattern"
- (wrapGenSpan $ genHsApp fail_op (mk_fail_msg_expr dflags pat))
+ (wrapGenSpan [ mkHsCaseAltDoExp pat lexpr -- pat -> expr
+ , mkHsCaseAlt nlWildPatName -- _ -> fail "fail pattern"
+ (wrapGenSpan $ genHsApp fail_op (mk_fail_msg_expr dflags pat))
]))
where
mk_fail_msg_expr :: DynFlags -> LPat GhcRn -> LHsExpr GhcRn
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7ff1c26dafd53b1c836df8f7d0db1b6c265ee6c4...ecdb4bd6e4b74a48208df4568a4f1d6ec89d62b0
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7ff1c26dafd53b1c836df8f7d0db1b6c265ee6c4...ecdb4bd6e4b74a48208df4568a4f1d6ec89d62b0
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/20230529/4fefd2e0/attachment-0001.html>
More information about the ghc-commits
mailing list