[Git][ghc/ghc][wip/expand-do] PopSrcSpan should be followed by tcApp
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Fri May 26 23:18:10 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
fc434c12 by Apoorv Ingle at 2023-05-26T18:18:01-05:00
PopSrcSpan should be followed by tcApp
- - - - -
9 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Match.hs
- testsuite/tests/rebindable/all.T
- + testsuite/tests/rebindable/pattern-fails
- testsuite/tests/rebindable/T18324.hs → testsuite/tests/typecheck/should_compile/T18324.hs
- testsuite/tests/typecheck/should_compile/all.T
- + testsuite/tests/typecheck/should_run/Typeable1
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -465,14 +465,10 @@ data XXExprGhcRn
-- Should not presist post typechecking
-- Note [Desugaring Do with HsExpansion] in GHC.Tc.Gen.Match
-
+-- | Wrap a located expression with a PopSrcExpr
mkPopSrcSpanExpr :: LHsExpr GhcRn -> HsExpr GhcRn
mkPopSrcSpanExpr a = XExpr (PopSrcSpan a)
--- | Generated location for PopSrcExpr
-genPopSrcSpanExpr :: LHsExpr GhcRn -> LHsExpr GhcRn
-genPopSrcSpanExpr = noLocA . mkPopSrcSpanExpr
-
-- | Build a 'HsExpansion' out of an extension constructor,
-- and the two components of the expansion: original and
-- desugared expressions.
@@ -488,12 +484,6 @@ mkExpandedStmt
-> HsExpr GhcRn -- ^ suitably wrapped 'HsExpansion'
mkExpandedStmt a b = XExpr (ExpandedStmt (HsExpanded a b))
-mkExpandedStmtLExpr
- :: ExprLStmt GhcRn -- ^ source statement
- -> LHsExpr GhcRn -- ^ expanded expression
- -> LHsExpr GhcRn -- ^ suitably wrapped 'HsExpansion'
-mkExpandedStmtLExpr a b = noLocA $ mkExpandedStmt a b
-
data XXExprGhcTc
= WrapExpr -- Type and evidence application and abstractions
{-# UNPACK #-} !(HsWrap HsExpr)
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -858,7 +858,6 @@ warnUnusedBindValue :: LHsExpr GhcTc -> LHsExpr GhcTc -> Type -> DsM ()
warnUnusedBindValue fun arg@(L loc _) arg_ty
| Just (l, f) <- fish_var fun
, f `hasKey` thenMClassOpKey -- it is a (>>)
- , isGeneratedSrcSpan l -- it is compiler generated (>>)
= do tracePm "warnUnusedBindValue" (vcat [ text "fun" <+> ppr fun
, text "loc" <+> ppr l
, text "locGen?" <+> ppr (isGeneratedSrcSpan l)
@@ -866,7 +865,9 @@ warnUnusedBindValue fun arg@(L loc _) arg_ty
, text "arg" <+> ppr arg
, text "arg_loc" <+> ppr loc
])
- putSrcSpanDs (locA loc) $ warnDiscardedDoBindings arg arg_ty
+ when (isGeneratedSrcSpan l || isNoSrcSpan l -- it is compiler generated (>>)
+ ) $
+ putSrcSpanDs (locA loc) $ warnDiscardedDoBindings arg arg_ty
where
-- Retrieve the location info and the head of the application
-- It is important that we /do not/ look through HsApp to avoid
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -208,6 +208,7 @@ 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 e@(HsOverLit _ lit) res_ty
= do { mb_res <- tcShortCutLit lit res_ty
@@ -409,8 +410,6 @@ tcExpr (HsMultiIf _ alts) res_ty
; return (HsMultiIf res_ty alts') }
where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }
-tcExpr (XExpr (PopSrcSpan expr)) res_ty = popErrCtxt $ tcExpr (unLoc expr) res_ty
-
tcExpr (XExpr (ExpandedStmt (HsExpanded stmt expr))) res_ty
= do { traceTc "tcDoStmts" (vcat [ text "stmt:" <+> ppr stmt
, text "expr:" <+> ppr expr
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -1181,6 +1181,18 @@ checkArgCounts matchContext (MG { mg_alts = L _ (match1:matches) })
* *
************************************************************************
-}
+
+
+-- | Generated location for PopSrcExpr
+genPopSrcSpanExpr :: LHsExpr GhcRn -> LHsExpr GhcRn
+genPopSrcSpanExpr = wrapGenSpan . mkPopSrcSpanExpr
+
+mkExpandedStmtLExpr
+ :: ExprLStmt GhcRn -- ^ source statement
+ -> LHsExpr GhcRn -- ^ expanded expression
+ -> LHsExpr GhcRn -- ^ suitably wrapped 'HsExpansion'
+mkExpandedStmtLExpr a b = noLocA $ mkExpandedStmt a b
+
expandDoStmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn)
expandDoStmts = expand_do_stmts
@@ -1206,18 +1218,27 @@ expand_do_stmts _ [stmt@(L loc (LastStmt _ body _ ret_expr))]
-- 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 $ mkExpandedStmtLExpr stmt
- (genPopSrcSpanExpr body)
+ = return $ mkExpandedStmtLExpr stmt body
| SyntaxExprRn ret <- ret_expr
--
-- ------------------------------------------------
-- return e ~~> return e
-- to make T18324 work
- = return $ genPopSrcSpanExpr $ L loc $ mkExpandedStmt stmt
- (genPopSrcSpanExpr (L loc (genHsApp ret body)))
+ = return $ L loc (mkExpandedStmt stmt
+ ((L loc (genHsApp ret body))))
+expand_do_stmts do_or_lc (stmt@(L loc (LetStmt _ bnds)) : lstmts) =
+-- stmts ~~> stmts'
+-- ------------------------------------------------
+-- let x = e ; stmts ~~> let x = e in stmts'
+ do expand_stmts <- expand_do_stmts do_or_lc lstmts
+ return $ L loc $ mkExpandedStmt stmt
+ (wrapGenSpan (HsLet noExtField
+ noHsTok bnds
+ noHsTok (genPopSrcSpanExpr expand_stmts)))
+
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 =
@@ -1229,33 +1250,22 @@ 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) -- (>>=)
- [ L loc (mkExpandedStmt stmt $ (genPopSrcSpanExpr e))
- , genPopSrcSpanExpr expr
- ])
+ return $ mkHsApps (wrapGenSpan bind_op) -- (>>=)
+ [ genPopSrcSpanExpr $ L loc (mkExpandedStmt stmt e)
+ , expr
+ ]
| otherwise = pprPanic "expand do: shouldn't happen" (text "stmt" <+> ppr stmt)
-expand_do_stmts do_or_lc (stmt@(L _ (LetStmt _ bnds)) : lstmts) =
--- stmts ~~> stmts'
--- ------------------------------------------------
--- let x = e ; stmts ~~> let x = e in stmts'
- do expand_stmts <- expand_do_stmts do_or_lc lstmts
- return $ mkExpandedStmtLExpr stmt
- (wrapGenSpan (HsLet noExtField
- noHsTok bnds
- noHsTok (genPopSrcSpanExpr expand_stmts)))
-
-
expand_do_stmts do_or_lc (stmt@(L loc (BodyStmt _ e (SyntaxExprRn f) _)) : lstmts) =
-- See Note [BodyStmt]
-- stmts ~~> stmts'
-- ----------------------------------------------
-- e ; stmts ~~> (>>) e stmts'
do expand_stmts <- expand_do_stmts do_or_lc lstmts
- return $ (genPopSrcSpanExpr $ (mkHsApps (wrapGenSpan f) -- (>>)
- [ L loc (mkExpandedStmt stmt $ (genPopSrcSpanExpr e)) -- e
- , genPopSrcSpanExpr expand_stmts ])) -- stmts'
+ return $ (mkHsApps (wrapGenSpan f) -- (>>)
+ [ L loc (mkPopSrcSpanExpr $ L loc (mkExpandedStmt stmt e)) -- e
+ , expand_stmts ]) -- stmts'
expand_do_stmts do_or_lc
((L do_loc (RecStmt { recS_stmts = L stmts_loc rec_stmts
@@ -1287,7 +1297,7 @@ expand_do_stmts do_or_lc
all_ids = local_only_ids ++ later_ids -- put local ids before return ids
return_stmt :: ExprLStmt GhcRn
- return_stmt = noLocA $ LastStmt noExtField
+ return_stmt = wrapGenSpan $ LastStmt noExtField
(mkBigLHsTup (map nlHsVar all_ids) noExtField)
Nothing
(SyntaxExprRn return_fun)
@@ -1300,7 +1310,7 @@ expand_do_stmts do_or_lc
-- LazyPat becuase we do not want to eagerly evaluate the pattern
-- and potentially loop forever
-expand_do_stmts do_or_lc (stmt@(L _ (ApplicativeStmt _ args mb_join)): lstmts) =
+expand_do_stmts do_or_lc ((L _ (ApplicativeStmt _ args mb_join)): lstmts) =
-- See Note [Applicative BodyStmt]
--
-- stmts ~~> stmts'
@@ -1318,30 +1328,29 @@ expand_do_stmts do_or_lc (stmt@(L _ (ApplicativeStmt _ args mb_join)): lstmts) =
; body_with_fails <- foldrM match_args expr' pats_can_fail
-- builds (body <$> e1 <*> e2 ...)
- ; let expand_ado_expr = genPopSrcSpanExpr $ foldl mk_apps body_with_fails (zip (map fst args) rhss)
+ ; let expand_ado_expr = foldl mk_apps body_with_fails (zip (map fst args) rhss)
-- wrap the expanded expression with a `join` if needed
; case mb_join of
- Nothing -> return $ mkExpandedStmtLExpr stmt expand_ado_expr
- Just NoSyntaxExprRn -> return $ mkExpandedStmtLExpr stmt expand_ado_expr -- why can this happen?
+ Nothing -> return $ expand_ado_expr
+ Just NoSyntaxExprRn -> return $ expand_ado_expr -- why can this happen?
Just (SyntaxExprRn join_op) ->
- return $ mkExpandedStmtLExpr stmt
- ( mkHsApp (wrapGenSpan join_op) expand_ado_expr)
+ return $ mkHsApp (wrapGenSpan join_op) (genPopSrcSpanExpr $ expand_ado_expr)
}
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 ++ [noLocA $ mkLastStmt (wrapGenSpan ret)]
+ do { expr <- expand_do_stmts do_or_lc $ stmts ++ [wrapGenSpan $ mkLastStmt (wrapGenSpan ret)]
; return ((pat, Nothing), expr) }
match_args :: (LPat GhcRn, FailOperator GhcRn) -> LHsExpr GhcRn -> TcM (LHsExpr GhcRn)
- match_args (pat, fail_op) body = genPopSrcSpanExpr <$> mk_failable_lexpr_tcm pat body fail_op
+ match_args (pat, fail_op) body = mk_failable_lexpr_tcm pat body fail_op
mk_apps l_expr (op, r_expr) =
case op of
- SyntaxExprRn op -> mkHsApps (wrapGenSpan op) [genPopSrcSpanExpr l_expr, genPopSrcSpanExpr r_expr]
+ SyntaxExprRn op -> mkHsApps (wrapGenSpan op) [l_expr, r_expr]
NoSyntaxExprRn -> pprPanic "expand_do_stmts op:" (ppr op)
expand_do_stmts _ stmts = pprPanic "expand_do_stmts: impossible happened" $ (ppr stmts)
@@ -1375,10 +1384,10 @@ mk_failable_lexpr_tcm pat lexpr fail_op =
mk_fail_lexpr :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn)
mk_fail_lexpr pat lexpr (Just (SyntaxExprRn fail_op)) =
do dflags <- getDynFlags
- return $ noLocA (HsLam noExtField $ mkMatchGroup (Generated DoExpansion) -- \
- (noLocA [ mkHsCaseAlt pat (genPopSrcSpanExpr lexpr) -- pat -> expr
+ return $ wrapGenSpan (HsLam noExtField $ mkMatchGroup (Generated DoExpansion) -- \
+ (wrapGenSpan [ mkHsCaseAlt pat (genPopSrcSpanExpr lexpr) -- pat -> expr
, mkHsCaseAlt nlWildPatName -- _ -> fail "fail pattern"
- (noLocA $ genHsApp fail_op (mk_fail_msg_expr dflags pat))
+ (wrapGenSpan $ genHsApp fail_op (mk_fail_msg_expr dflags pat))
]))
where
mk_fail_msg_expr :: DynFlags -> LPat GhcRn -> LHsExpr GhcRn
=====================================
testsuite/tests/rebindable/all.T
=====================================
@@ -42,8 +42,7 @@ test('T14670', expect_broken(14670), compile, [''])
test('T19167', normal, compile, [''])
test('T19918', normal, compile_and_run, [''])
test('T20126', normal, compile_fail, [''])
-# Tests for desugaring do before typechecking
-test('T18324', normal, compile, [''])
+# Tests for expanding do before typechecking
test('T23147', normal, compile, [''])
test('pattern-fails', normal, compile_and_run, [''])
test('simple-rec', normal, compile_and_run, [''])
=====================================
testsuite/tests/rebindable/pattern-fails
=====================================
Binary files /dev/null and b/testsuite/tests/rebindable/pattern-fails differ
=====================================
testsuite/tests/rebindable/T18324.hs → testsuite/tests/typecheck/should_compile/T18324.hs
=====================================
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -875,3 +875,5 @@ test('T23171', normal, compile, [''])
test('T23192', normal, compile, [''])
test('T23199', normal, compile, [''])
test('T23156', normal, compile, [''])
+# Tests for expanding do before typechecking (Impredicative)
+test('T18324', normal, compile, [''])
=====================================
testsuite/tests/typecheck/should_run/Typeable1
=====================================
Binary files /dev/null and b/testsuite/tests/typecheck/should_run/Typeable1 differ
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fc434c1208b30f26381d965f074933dd811d012f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fc434c1208b30f26381d965f074933dd811d012f
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/20230526/f858e72a/attachment-0001.html>
More information about the ghc-commits
mailing list