[Git][ghc/ghc][wip/expand-do] do not add argument context if it is a do statement

[Apoorv Ingle (@ani)]

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


Commits:
e13451b4 by Apoorv Ingle at 2023-06-23T17:04:58-05:00
do not add argument context if it is a do statement

- - - - -


3 changed files:

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


Changes:

=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -264,10 +264,7 @@ dsExpr (HsOverLit _ lit)
 
 dsExpr e@(XExpr ext_expr_tc)
   = case ext_expr_tc of
-      ExpansionExpr (HsExpanded orig b) ->
-        case isSingleDoStmt orig of
-             Just loc -> putSrcSpanDsA loc $ dsExpr b
-             Nothing  -> dsExpr b
+      ExpansionExpr (HsExpanded _ b) -> dsExpr b
       WrapExpr {}                    -> dsHsWrapped e
       ConLikeTc con tvs tys          -> dsConLike con tvs tys
       -- Hpc Support
@@ -287,9 +284,6 @@ dsExpr e@(XExpr ext_expr_tc)
         do { assert (exprType e2 `eqType` boolTy)
             mkBinaryTickBox ixT ixF e2
           }
-  where
-    isSingleDoStmt (HsDo _ _ (L _ [L loc _])) = Just loc
-    isSingleDoStmt _ = Nothing
 
 -- Strip ticks due to #21701, need to be invariant about warnings we produce whether
 -- this is enabled or not.


=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -734,6 +734,10 @@ addArgCtxt ctxt (L arg_loc arg) thing_inside
                    setSrcSpanA arg_loc                    $
                      addErrCtxt (funAppCtxt fun arg arg_no) $
                      thing_inside
+           VACall fun _ _ | not in_generated_code && (is_then_fun fun || is_bind_fun fun)
+             -> do traceTc "addArgCtxt 2b" empty -- Skip setting "In the expression..."
+                                                 -- We have already set the context "In the stmt"
+                   thing_inside
            _ -> do traceTc "addArgCtxt 3" empty
                    setSrcSpanA arg_loc $
                      addExprCtxt arg     $  -- Auto-suppressed if arg_loc is generated


=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -1244,7 +1244,7 @@ expand_do_stmts do_or_lc (stmt@(L _ (LetStmt _ bs)) : lstmts) =
   do expand_stmts <- expand_do_stmts do_or_lc lstmts
      return $ wrapGenSpan (mkExpandedStmt stmt (genHsLet bs $ genPopSrcSpanExpr expand_stmts))
 
-expand_do_stmts do_or_lc (stmt@(L _ (BindStmt xbsrn pat e)): lstmts)
+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 =
 -- the pattern binding pat can fail
@@ -1258,14 +1258,14 @@ expand_do_stmts do_or_lc (stmt@(L _ (BindStmt xbsrn pat e)): lstmts)
          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))  -- (>>=)
-                          `genHsApp`
-                          expr
-                        )
+         return $ wrapGenSpan (mkPopSrcSpanExpr $ L loc (mkExpandedStmt stmt (
+                     (wrapGenSpan bind_op)
+                       `genHsApp` e))  -- (>>=)
+                     `genHsApp`
+                         expr)
   | otherwise = pprPanic "expand do: shouldn't happen"  (text "stmt" <+> ppr  stmt)
 
-expand_do_stmts do_or_lc (stmt@(L _ (BodyStmt _ e (SyntaxExprRn then_op) _)) : lstmts) =
+expand_do_stmts do_or_lc (stmt@(L loc (BodyStmt _ e (SyntaxExprRn then_op) _)) : lstmts) =
 -- See Note [BodyStmt]
 --              stmts ~~> stmts'
 --    ----------------------------------------------
@@ -1274,7 +1274,7 @@ expand_do_stmts do_or_lc (stmt@(L _ (BodyStmt _ e (SyntaxExprRn then_op) _)) : l
      -- 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 (
+     return $ wrapGenSpan (mkPopSrcSpanExpr $ L loc (mkExpandedStmt stmt (
                   (wrapGenSpan then_op) -- (>>)
                     `genHsApp` e))
                 `genHsApp`



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e13451b4a16e0beb09a063ef2941fce9dc0a6beb
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/20230623/1c5f4596/attachment-0001.html>