[Git][ghc/ghc][wip/expansions-appdo] in GHC.Tc.Gen.Do.mk_apps pull out the XExpr annotation outside the op application
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Mon Apr 29 05:14:26 UTC 2024
Apoorv Ingle pushed to branch wip/expansions-appdo at Glasgow Haskell Compiler / GHC
Commits:
7e4ed6b0 by Apoorv Ingle at 2024-04-29T00:14:10-05:00
in GHC.Tc.Gen.Do.mk_apps pull out the XExpr annotation outside the op application
- - - - -
3 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Match.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -846,7 +846,7 @@ instance Outputable HsThingRn where
where ppr_builder prefix x = ifPprDebug (braces (text prefix <+> parens (ppr x))) (ppr x)
instance Outputable XXExprGhcRn where
- ppr (ExpandedThingRn o e) = ifPprDebug (braces $ vcat [ppr o, ppr e]) (ppr o)
+ ppr (ExpandedThingRn o e) = ifPprDebug (braces $ vcat [ppr o, text ";;" , ppr e]) (ppr o)
ppr (PopErrCtxt e) = ifPprDebug (braces (text "<PopErrCtxt>" <+> ppr e)) (ppr e)
instance Outputable XXExprGhcTc where
=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -21,7 +21,7 @@ module GHC.Tc.Gen.Do (expandDoStmts) where
import GHC.Prelude
-import GHC.Rename.Utils ( wrapGenSpan, genHsExpApps, genHsApp, genHsLet, genLHsApp,
+import GHC.Rename.Utils ( wrapGenSpan, genHsExpApps, genHsApp, genHsLet,
genHsLamDoExp, genHsCaseAltDoExp, genWildPat )
import GHC.Tc.Utils.Monad
import GHC.Tc.Gen.Pat
@@ -53,14 +53,14 @@ import Data.List ((\\))
-- so that they can be typechecked.
-- See Note [Expanding HsDo with XXExprGhcRn] below for `HsDo` specific commentary
-- and Note [Handling overloaded and rebindable constructs] for high level commentary
-expandDoStmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn)
+expandDoStmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (HsExpr GhcRn)
expandDoStmts doFlav stmts = do expanded_expr <- expand_do_stmts doFlav stmts
case expanded_expr of
- L _ (XExpr (PopErrCtxt e)) -> return e
+ L _ (XExpr (PopErrCtxt e)) -> return $ unLoc e
-- The first expanded stmt doesn't need a pop as
-- it would otherwise pop the "In the expression do ... " from
-- the error context
- _ -> return expanded_expr
+ _ -> return $ unLoc expanded_expr
-- | The main work horse for expanding do block statements into applications of binds and thens
-- See Note [Expanding HsDo with XXExprGhcRn]
@@ -213,7 +213,8 @@ expand_do_stmts doFlavour ((L _ (ApplicativeStmt _ args mb_join)): lstmts) =
-- wrap the expanded expression with a `join` if needed
; let final_expr = case mb_join of
- Just (SyntaxExprRn join_op) -> genLHsApp join_op (wrapGenSpan $ unLoc expand_ado_expr)
+ Just (SyntaxExprRn join_op)
+ -> genLHsApp join_op expand_ado_expr
_ -> expand_ado_expr
; traceTc "expand_do_stmts AppStmt" (vcat [ text "args:" <+> ppr args
, text "lstmts:" <+> ppr lstmts
@@ -229,14 +230,16 @@ expand_do_stmts doFlavour ((L _ (ApplicativeStmt _ args mb_join)): lstmts) =
, arg_expr = (L rhs_loc rhs)
, is_body_stmt = is_body_stmt
}) =
- do traceTc "do_arg" (text "OneArg" <+> ppr (L rhs_loc rhs))
+ do let xx_stmt = mkExpandedStmtAt rhs_loc stmt doFlavour rhs
+ traceTc "do_arg" (text "OneArg" <+> ppr xx_stmt)
return ((pat, mb_fail_op)
- , mkExpandedStmtAt rhs_loc stmt doFlavour rhs)
+ , xx_stmt)
where stmt = if is_body_stmt
then (L rhs_loc (BodyStmt NoExtField (L rhs_loc rhs) NoSyntaxExprRn NoSyntaxExprRn))
else (L rhs_loc (BindStmt xbsn pat (L rhs_loc rhs)))
do_arg (ApplicativeArgMany _ stmts ret@(L ret_loc _) pat ctxt) =
do { expr <- expand_do_stmts ctxt $ stmts ++ [L ret_loc $ mkLastStmt ret]
+ ; traceTc "do_arg" (text "ManyArg" <+> ppr expr)
; return ((pat, Nothing)
, expr) }
@@ -251,7 +254,7 @@ expand_do_stmts doFlavour ((L _ (ApplicativeStmt _ args mb_join)): lstmts) =
case op of
SyntaxExprRn op -> case r_expr of
L loc (XExpr (ExpandedThingRn (OrigStmt (L l s) flav) e))
- -> L loc $ XExpr (ExpandedThingRn (OrigStmt (L l s) flav)
+ -> wrapGenSpan $ XExpr (ExpandedThingRn (OrigStmt (L l s) flav)
(genHsExpApps op [ l_expr
, L loc e ]))
_ -> wrapGenSpan $ genHsExpApps op [ l_expr, r_expr ]
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -82,7 +82,6 @@ import Control.Arrow ( second )
import qualified Data.List.NonEmpty as NE
import Data.Maybe (mapMaybe)
-
{-
************************************************************************
* *
@@ -352,13 +351,15 @@ tcDoStmts ListComp (L l stmts) res_ty
; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) }
tcDoStmts doExpr@(DoExpr _) ss@(L _ stmts) res_ty
- = do { expanded_expr <- expandDoStmts doExpr stmts -- Do expansion on the fly
- ; mkExpandedExprTc (HsDo noExtField doExpr ss) <$> tcExpr (unLoc expanded_expr) res_ty
+ = do { traceTc "tcDoStmts" $ text "original:" <+> ppr ss
+ ; expanded_expr <- expandDoStmts doExpr stmts -- Do expansion on the fly
+ ; traceTc "tcDoStmts" $ text "expansion:" <+> ppr expanded_expr
+ ; mkExpandedExprTc (HsDo noExtField doExpr ss) <$> tcExpr expanded_expr res_ty
}
tcDoStmts mDoExpr@(MDoExpr _) ss@(L _ stmts) res_ty
= do { expanded_expr <- expandDoStmts mDoExpr stmts -- Do expansion on the fly
- ; mkExpandedExprTc (HsDo noExtField mDoExpr ss) <$> tcExpr (unLoc expanded_expr) res_ty }
+ ; mkExpandedExprTc (HsDo noExtField mDoExpr ss) <$> tcExpr expanded_expr res_ty }
tcDoStmts MonadComp (L l stmts) res_ty
= do { stmts' <- tcStmts (HsDoStmt MonadComp) tcMcStmt stmts res_ty
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7e4ed6b0dfff14f5860921480bed5643ea0514e9
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7e4ed6b0dfff14f5860921480bed5643ea0514e9
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/20240429/0a620b8d/attachment-0001.html>
More information about the ghc-commits
mailing list