[Git][ghc/ghc][wip/expansions-appdo] make sure app do expression statements location is mapped correctly
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Mon Mar 25 02:55:19 UTC 2024
Apoorv Ingle pushed to branch wip/expansions-appdo at Glasgow Haskell Compiler / GHC
Commits:
5bda9532 by Apoorv Ingle at 2024-03-24T21:50:12-05:00
make sure app do expression statements location is mapped correctly
- - - - -
5 changed files:
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Utils/Monad.hs
- testsuite/tests/ado/ado004.stderr
Changes:
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -797,11 +797,15 @@ addArgCtxt :: AppCtxt -> LHsExpr GhcRn
addArgCtxt ctxt (L arg_loc arg) thing_inside
= do { in_generated_code <- inGeneratedCode
; case ctxt of
- VACall fun arg_no _ | not in_generated_code
+ VACall fun arg_no _
+ | not in_generated_code
-> do setSrcSpanA arg_loc $
addErrCtxt (funAppCtxt fun arg arg_no) $
thing_inside
+ | XExpr{} <- arg, in_generated_code
+ -> thing_inside -- AppDo case for <*>'s second argument, the ctxt will be set by addHeadCtxt
+
VAExpansion (OrigStmt (L _ stmt@(BindStmt {}))) _ loc
| isGeneratedSrcSpan (locA arg_loc) -- This arg is the second argument to generated (>>=)
-> setSrcSpan loc $
@@ -817,8 +821,8 @@ addArgCtxt ctxt (L arg_loc arg) thing_inside
thing_inside
_ -> setSrcSpanA arg_loc $
- addExprCtxt arg $ -- Auto-suppressed if arg_loc is generated
- thing_inside }
+ addExprCtxt arg $ -- Auto-suppressed if arg_loc is generated
+ thing_inside }
{- *********************************************************************
* *
=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -87,7 +87,10 @@ expand_do_stmts _ [stmt@(L loc (LastStmt _ (L body_loc 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 $ mkExpandedStmtPopAt loc stmt body
+ appDo <- xoptM LangExt.ApplicativeDo
+ if appDo
+ then return $ mkExpandedStmtAt loc stmt body
+ else return $ mkExpandedStmtPopAt loc stmt body
| SyntaxExprRn ret <- ret_expr
--
@@ -220,14 +223,14 @@ expand_do_stmts doFlavour ((L _ (ApplicativeStmt _ args mb_join)): lstmts) =
do_arg :: ApplicativeArg GhcRn -> TcM ((LPat GhcRn, FailOperator GhcRn), LHsExpr GhcRn)
do_arg (ApplicativeArgOne
{ xarg_app_arg_one = mb_fail_op
- , app_arg_pattern = pat@(L loc _)
- , arg_expr = rhs
+ , app_arg_pattern = pat
+ , arg_expr = (L rhs_loc rhs)
}) =
- return ((pat, mb_fail_op), mkExpandedStmtAt loc (L loc (BindStmt xbsn pat rhs)) (unLoc rhs))
+ return ((pat, mb_fail_op), mkExpandedStmtAt rhs_loc (L rhs_loc (BindStmt xbsn pat (L rhs_loc rhs))) rhs)
do_arg (ApplicativeArgMany _ stmts ret pat ctxt) =
do { expr <- expand_do_stmts ctxt $ stmts ++ [wrapGenSpan $ mkLastStmt (wrapGenSpan ret)]
; return ((pat, Nothing)
- , {- wrapGenSpan $ mkExpandedExpr (HsDo noExtField ctxt (wrapGenSpan stmts)) (unLoc expr)-} expr) }
+ , expr) }
match_args :: (LPat GhcRn, FailOperator GhcRn) -> HsExpr GhcRn -> TcM (HsExpr GhcRn)
match_args (pat, fail_op) body = unLoc <$> mk_failable_expr doFlavour pat (wrapGenSpan body) fail_op
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -897,15 +897,18 @@ tcInferAppHead_maybe fun
addHeadCtxt :: AppCtxt -> TcM a -> TcM a
addHeadCtxt (VAExpansion (OrigStmt (L loc stmt)) _ _) thing_inside =
- do setSrcSpanA loc $
+ do traceTc "addHeadCtxt stmt" (ppr stmt)
+ setSrcSpanA loc $
addStmtCtxt stmt
thing_inside
addHeadCtxt fun_ctxt thing_inside
| not (isGoodSrcSpan fun_loc) -- noSrcSpan => no arguments
- = thing_inside -- => context is already set
+ = do traceTc "addHeadCtxt notGood" empty
+ thing_inside -- => context is already set
| otherwise
= setSrcSpan fun_loc $
- do case fun_ctxt of
+ do traceTc "addHeadCtxt fun_loc" (ppr fun_loc)
+ case fun_ctxt of
VAExpansion (OrigExpr orig) _ _ -> addExprCtxt orig thing_inside
_ -> thing_inside
where
@@ -1640,6 +1643,7 @@ addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt e thing_inside
= case e of
HsUnboundVar {} -> thing_inside
+ XExpr (ExpandedThingRn (OrigStmt stmt) _) -> addStmtCtxt (unLoc stmt) thing_inside
_ -> addErrCtxt (exprCtxt e) thing_inside
-- The HsUnboundVar special case addresses situations like
-- f x = _
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -1230,7 +1230,7 @@ setErrCtxt ctxt = updLclEnv (setLclEnvErrCtxt ctxt)
-- do any tidying.
addErrCtxt :: SDoc -> TcM a -> TcM a
{-# INLINE addErrCtxt #-} -- Note [Inlining addErrCtxt]
-addErrCtxt msg thing_inside = dbgErrCtxt (addErrCtxtM (\env -> return (env, msg)) thing_inside)
+addErrCtxt msg thing_inside = dbgErrCtxt msg (addErrCtxtM (\env -> return (env, msg)) thing_inside)
-- | Add a message to the error context. This message may do tidying.
addErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, SDoc)) -> TcM a -> TcM a
@@ -1255,11 +1255,11 @@ pushCtxt :: ErrCtxt -> TcM a -> TcM a
{-# INLINE pushCtxt #-} -- Note [Inlining addErrCtxt]
pushCtxt ctxt = updLclEnv (updCtxt ctxt)
-dbgErrCtxt :: TcM a -> TcM a
-dbgErrCtxt thing_inside =
+dbgErrCtxt :: SDoc -> TcM a -> TcM a
+dbgErrCtxt msg thing_inside =
do errCtxt <- getErrCtxt
info <- mkErrInfo emptyTidyEnv errCtxt
- traceTc "--Debug Error Context--" (ppr info)
+ traceTc "--Debug Error Context--" (vcat [ppr msg, text "----", ppr info, text "----"])
thing_inside
updCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv
@@ -1270,7 +1270,7 @@ updCtxt ctxt env
| otherwise = addLclEnvErrCtxt ctxt env
popErrCtxt :: TcM a -> TcM a
-popErrCtxt thing_inside = dbgErrCtxt $ updLclEnv (\env -> setLclEnvErrCtxt (pop $ getLclEnvErrCtxt env) env) $
+popErrCtxt thing_inside = dbgErrCtxt (text "PopErrCtxt") $ updLclEnv (\env -> setLclEnvErrCtxt (pop $ getLclEnvErrCtxt env) env) $
thing_inside
where
pop [] = []
=====================================
testsuite/tests/ado/ado004.stderr
=====================================
@@ -8,24 +8,24 @@ TYPE SIGNATURES
test1c ::
forall (f :: * -> *). Applicative f => (Int -> f Int) -> f Int
test2 ::
- forall {f :: * -> *} {t} {b}.
- (Applicative f, Num t, Num b) =>
+ forall {f :: * -> *} {b} {t}.
+ (Applicative f, Num b, Num t) =>
(t -> f b) -> f b
test2a ::
- forall {f :: * -> *} {t} {b}.
- (Functor f, Num t, Num b) =>
+ forall {f :: * -> *} {b} {t}.
+ (Functor f, Num b, Num t) =>
(t -> f b) -> f b
test2b ::
forall {f :: * -> *} {t} {a}.
(Applicative f, Num t) =>
(t -> a) -> f a
test2c ::
- forall {f :: * -> *} {t} {b}.
- (Functor f, Num t, Num b) =>
+ forall {f :: * -> *} {b} {t}.
+ (Functor f, Num b, Num t) =>
(t -> f b) -> f b
test2d ::
- forall {f :: * -> *} {t} {b} {a}.
- (Functor f, Num t, Num b) =>
+ forall {f :: * -> *} {b} {t} {a}.
+ (Functor f, Num b, Num t) =>
(t -> f a) -> f b
test3 ::
forall {m :: * -> *} {t1} {t2} {a}.
@@ -44,4 +44,4 @@ TYPE SIGNATURES
(Monad m, Num (m a)) =>
(m a -> m (m a)) -> p -> m a
Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [base-4.20.0.0]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5bda953219ac72c667dcbd9f9fa73c0b70238441
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5bda953219ac72c667dcbd9f9fa73c0b70238441
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/20240324/979048df/attachment-0001.html>
More information about the ghc-commits
mailing list