[Git][ghc/ghc][wip/expand-do] add stmt context in tcApp rather other places

[Apoorv Ingle (@ani)]

Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC


Commits:
e203ab70 by Apoorv Ingle at 2023-06-19T09:58:16-05:00
add stmt context in tcApp rather other places

- - - - -


3 changed files:

- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Match.hs


Changes:

=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -355,7 +355,11 @@ tcApp rn_expr exp_res_ty
        --    Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr
        ; let  perhaps_add_res_ty_ctxt thing_inside
                  | insideExpansion fun_ctxt || isGeneratedSrcSpan (appCtxtLoc fun_ctxt)
-                 = do traceTc "insideExpansion" (vcat [ppr rn_fun, ppr fun_ctxt])
+                 , VACall (XExpr (ExpandedStmt (HsExpanded stmt@(L loc _) _))) _ _ <- fun_ctxt
+                 = do traceTc "insideExpansion stmt" (vcat [ppr rn_fun, ppr fun_ctxt])
+                      setSrcSpanA loc $ addStmtCtxt stmt thing_inside
+                 | insideExpansion fun_ctxt -- || isGeneratedSrcSpan (appCtxtLoc fun_ctxt)
+                 = do traceTc "insideExpansion no stmt" (vcat [ppr rn_fun, ppr fun_ctxt])
                       addHeadCtxt fun_ctxt thing_inside
                  | otherwise
                  = do traceTc "no expansion" (ppr rn_fun)
@@ -705,7 +709,9 @@ addArgCtxt ctxt (L arg_loc arg) thing_inside
                                     , text "arg_loc" <+> ppr arg_loc
                                     , text "is src ctxt" <+> ppr in_src_ctxt
                                     , text "is generated code" <+> ppr in_generated_code
-                                    , text "is then" <+> ppr (is_then_fun (appCtxtExpr ctxt)) ])
+                                    , text "is then/bind"
+                                      <+> ppr (is_then_fun (appCtxtExpr ctxt))
+                                      <+> ppr (is_bind_fun (appCtxtExpr ctxt)) ])
        ; case ctxt of
            VACall fun _ _ | not in_src_ctxt
                           , is_then_fun fun || is_bind_fun fun


=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -217,6 +217,7 @@ tcExpr (XExpr (ExpandedStmt (HsExpanded stmt@(L loc _) (L _ e)))) res_ty
   =  do { traceTc "tcDoStmts" (vcat [ text "stmt:" <+> ppr stmt
                                     , text "expr:" <+> ppr e
                                     , text "res_ty:" <+> ppr res_ty
+                                    , text "loc" <+> ppr loc
                                     ])
         ; setSrcSpanA loc $
           addStmtCtxt stmt $ tcExpr e res_ty
@@ -431,21 +432,23 @@ tcExpr (HsMultiIf _ alts) res_ty
 tcExpr hsDo@(HsDo _ doFlav@(DoExpr{}) (L _ stmts)) res_ty
   = do { expanded_expr <- expandDoStmts doFlav stmts
                                                -- Do expansion on the fly
-       ; let expanded_do_expr = mkExpandedExpr hsDo (unLoc expanded_expr)
+       ; -- let expanded_do_expr = mkExpandedExpr hsDo (unLoc expanded_expr)
        ; traceTc "tcDoStmts " (vcat [ text "hsDo:" <+> ppr hsDo
                                     , text "expr:" <+> ppr expanded_expr
                                     ])
-       ; tcExpr expanded_do_expr res_ty
+       ; -- addExprCtxt hsDo $
+         tcExpr (unLoc expanded_expr) res_ty
        }
 
 tcExpr hsDo@(HsDo _ doFlav@(MDoExpr{}) (L _ stmts)) res_ty
   = do { expanded_expr <- expandDoStmts doFlav stmts
                                                -- Do expansion on the fly
-       ; let expanded_do_expr = mkExpandedExpr hsDo (unLoc expanded_expr)
+       ; -- let expanded_do_expr = mkExpandedExpr hsDo (unLoc expanded_expr)
        ; traceTc "tcDoStmts " (vcat [ text "hsDo:" <+> ppr hsDo
                                     , text "expr:" <+> ppr expanded_expr
                                     ])
-       ; tcExpr expanded_do_expr res_ty
+       ; -- addExprCtxt hsDo $
+         tcExpr (unLoc expanded_expr) res_ty
        }
 
 tcExpr (HsDo _ do_or_lc stmts) res_ty


=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -1248,11 +1248,13 @@ expand_do_stmts do_or_lc (stmt@(L _ (BindStmt xbsrn pat e)): lstmts)
 --                                   _   = fail "Pattern match failure .."
 --    -------------------------------------------------------
 --       pat <- e ; stmts   ~~> (>>=) e f
-      do expand_stmts <- expand_do_stmts do_or_lc lstmts
+      do isRebindableOn <- xoptM LangExt.RebindableSyntax
+         let spanWrap = if isRebindableOn then noLocA else wrapGenSpan
+         expand_stmts <- expand_do_stmts do_or_lc lstmts
          expr@(L l _) <- mk_failable_lexpr_tcm pat expand_stmts fail_op
          traceTc "expand_do_stmts" (vcat [ text "loc ex stmts" <+> ppr l])
          return $ wrapGenSpan (mkPopSrcSpanExpr $ wrapGenSpan (mkExpandedStmt stmt (
-                     (wrapGenSpan bind_op) `genHsApp` e))  -- (>>=)
+                     (spanWrap bind_op) `genHsApp` e))  -- (>>=)
                           `genHsApp`
                           expr
                         )
@@ -1263,10 +1265,12 @@ expand_do_stmts do_or_lc (stmt@(L _ (BodyStmt _ e (SyntaxExprRn f) _)) : lstmts)
 --              stmts ~~> stmts'
 --    ----------------------------------------------
 --      e ; stmts ~~> (>>) e stmts'
-  do expand_stmts@(L l _) <- expand_do_stmts do_or_lc lstmts
+  do isRebindableOn <- xoptM LangExt.RebindableSyntax
+     let spanWrap = if isRebindableOn then noLocA else wrapGenSpan
+     expand_stmts@(L l _) <- expand_do_stmts do_or_lc lstmts
      traceTc "expand_do_stmts" (vcat [ text "loc ex stmts" <+> ppr l])
      return $ wrapGenSpan (mkPopSrcSpanExpr $ wrapGenSpan (mkExpandedStmt stmt (
-                  (wrapGenSpan f) -- (>>)
+                  (spanWrap f) -- (>>)
                     `genHsApp` e))
                 `genHsApp`
                      expand_stmts)  -- stmts'



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e203ab704f6c5b4279d7352827c476cc93dc0ac7

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e203ab704f6c5b4279d7352827c476cc93dc0ac7
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/20230619/518a2629/attachment-0001.html>