[Git][ghc/ghc][wip/expand-do] call tcExpr and not tcApp in PopSrcSpan so make sure impredicativity works fine
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Wed May 31 21:19:57 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
ba566946 by Apoorv Ingle at 2023-05-31T16:19:45-05:00
call tcExpr and not tcApp in PopSrcSpan so make sure impredicativity works fine
- - - - -
4 changed files:
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/Match.hs
Changes:
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -687,7 +687,7 @@ addArgCtxt :: AppCtxt -> LHsExpr GhcRn
-- (VAExpansion), just use the less-informative context
-- "In the expression: arg"
-- Unless the arg is also a generated thing, in which case do nothing.
----See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr
+--- See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr
addArgCtxt ctxt (L arg_loc arg) thing_inside
= do { in_generated_code <- inGeneratedCode
; case ctxt of
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -208,7 +208,20 @@ tcExpr e@(HsAppType {}) res_ty = tcApp e res_ty
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 = popErrCtxt $ tcApp (unLoc e) res_ty
+
+tcExpr (XExpr (PopSrcSpan e)) res_ty = popErrCtxt $ tcExpr (unLoc e) 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
+ ])
+ ; addErrCtxt (pprStmtInCtxt @Renamed @Renamed @Renamed (HsDoStmt (DoExpr Nothing)) (unLoc stmt)) $
+ tcApp (unLoc expr) res_ty
+ }
+
+
+
tcExpr e@(HsOverLit _ lit) res_ty
= do { mb_res <- tcShortCutLit lit res_ty
@@ -415,15 +428,6 @@ tcExpr (HsMultiIf _ alts) res_ty
; return (HsMultiIf res_ty alts') }
where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }
-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
- ])
- ; addErrCtxt (pprStmtInCtxt @Renamed @Renamed @Renamed (HsDoStmt (DoExpr Nothing)) (unLoc stmt)) $
- tcApp (unLoc expr) res_ty
- }
-
tcExpr hsDo@(HsDo _ doFlav@(DoExpr{}) (L _ stmts)) res_ty
= do { expand_expr <- expandDoStmts doFlav stmts
-- Do expansion on the fly
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -1466,8 +1466,6 @@ addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt e thing_inside
= case e of
HsUnboundVar {} -> thing_inside
- XExpr (ExpandedStmt (HsExpanded stmt _)) ->
- addErrCtxt (pprStmtInCtxt @Renamed @Renamed @Renamed (HsDoStmt (DoExpr Nothing)) (unLoc stmt)) thing_inside
_ -> addErrCtxt (exprCtxt e) thing_inside
-- The HsUnboundVar special case addresses situations like
-- f x = _
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -1238,7 +1238,7 @@ expand_do_stmts do_or_lc (stmt@(L loc (LetStmt _ bnds)) : lstmts) =
return $ L loc $ mkExpandedStmt stmt
(wrapGenSpan (HsLet noExtField
noHsTok bnds
- noHsTok (genPopSrcSpanExpr expand_stmts)))
+ noHsTok expand_stmts))
expand_do_stmts do_or_lc (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
| SyntaxExprRn bind_op <- xbsrn_bindOp xbsrn
@@ -1250,7 +1250,7 @@ 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 (noLocA $ mkExpandedStmt stmt expand_stmts) fail_op
+ expr <- mk_failable_lexpr_tcm pat expand_stmts fail_op
return $ (mkHsApps (wrapGenSpan bind_op) -- (>>=)
[ genPopSrcSpanExpr $ L loc (mkExpandedStmt stmt e)
, genPopSrcSpanExpr expr
@@ -1265,8 +1265,8 @@ expand_do_stmts do_or_lc (stmt@(L loc (BodyStmt _ e (SyntaxExprRn f) _)) : lstmt
-- e ; stmts ~~> (>>) e stmts'
do expand_stmts <- expand_do_stmts do_or_lc lstmts
return $ (mkHsApps (wrapGenSpan f) -- (>>)
- [ L loc (mkPopSrcSpanExpr $ L loc (mkExpandedStmt stmt e)) -- e
- , expand_stmts ]) -- stmts'
+ [ genPopSrcSpanExpr $ L loc (mkExpandedStmt stmt e) -- e
+ , genPopSrcSpanExpr expand_stmts ]) -- stmts'
expand_do_stmts do_or_lc
((L do_loc (RecStmt { recS_stmts = L stmts_loc rec_stmts
@@ -1394,7 +1394,7 @@ mk_fail_lexpr pat lexpr (Just (SyntaxExprRn fail_op)) =
do dflags <- getDynFlags
return $ wrapGenSpan (HsLam noExtField $ mkMatchGroup (Generated DoExpansion) -- \
(wrapGenSpan [ mkHsCaseAltDoExp pat lexpr -- pat -> expr
- , mkHsCaseAlt nlWildPatName -- _ -> fail "fail pattern"
+ , mkHsCaseAltDoExp nlWildPatName -- _ -> fail "fail pattern"
(wrapGenSpan $ genHsApp fail_op (mk_fail_msg_expr dflags pat))
]))
where
@@ -1428,9 +1428,12 @@ f = {g1} (>>=) ({l1'} e1) (\ p ->
)
The points to consider are:
-1. Generate appropriate warnings for discarded results, eg. say g p :: m Int
-2. Decorate an expression a fail block if the pattern match is irrefutable
-3. Generating approprate type error messages that blame the correct source spans
+1. Generating appropriate type error messages that blame the correct source spans
+2. Generate appropriate warnings for discarded results, eg. say g p :: m Int
+3. Decorate an expression a fail block if the pattern match is irrefutable
+
+Things get a bit tricky with QuickLook involved that decomposes the applications
+to perform an impredicativity check.
TODO expand using examples
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ba56694691955e3bcedaad9cf419cdcf0bab2796
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ba56694691955e3bcedaad9cf419cdcf0bab2796
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/20230531/a93ab80b/attachment-0001.html>
More information about the ghc-commits
mailing list