[Git][ghc/ghc][wip/expand-do] fixing location infos for stmts and their expansions

[Apoorv Ingle (@ani)]

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


Commits:
59168671 by Apoorv Ingle at 2023-07-26T13:56:05-05:00
fixing location infos for stmts and their expansions

- - - - -


3 changed files:

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


Changes:

=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -301,6 +301,7 @@ dsExpr (HsLamCase _ lc_variant matches)
 dsExpr e@(HsApp _ fun arg)
   = do { fun' <- dsLExpr fun
        ; arg' <- dsLExpr arg
+       ; tracePm "HsToCore dsExpr HsApp" (vcat [ppr fun, ppr arg])
        ; warnUnusedBindValue fun arg (exprType arg')
        ; return $ mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg' }
 


=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -369,7 +369,7 @@ tcApp rn_expr exp_res_ty
                       -- setSrcSpanA loc $ -- addStmtCtxt (text "tcApp VACall stmt") stmt
                       thing_inside
                  | insideExpansion fun_ctxt
-                 , VAExpansionStmt stmt loc <- fun_ctxt
+                 , VAExpansionStmt (L _ stmt) loc <- fun_ctxt
                  = do traceTc "tcApp" (vcat [text "VAExpansionStmt", ppr stmt, ppr loc, ppr rn_fun, ppr fun_ctxt])
                       --setSrcSpan loc $
                       addStmtCtxt (text "tcApp VAExpansionStmt") stmt
@@ -827,43 +827,29 @@ addArgCtxt ctxt (L arg_loc arg) thing_inside
                    setSrcSpanA arg_loc                    $
                      addErrCtxt (funAppCtxt fun arg arg_no) $
                      thing_inside
-           VAExpansionStmt stmt@(BodyStmt{}) loc
+           VAExpansionStmt stmt@(L loc BodyStmt{}) _
              -> do traceTc "addArgCtxt 2e body" empty
-                   setSrcSpan loc $
-                     addStmtCtxt ((text "addArgCtxt 2e")) stmt $
+                   setSrcSpanA loc $
+                     addStmtCtxt ((text "addArgCtxt 2e")) (unLoc stmt) $
                      thing_inside
-           VAExpansionStmt stmt@(LastStmt {}) loc
+           VAExpansionStmt stmt@(L _ LastStmt {}) loc
              -> do traceTc "addArgCtxt 2e last" empty
                    setSrcSpan loc $
-                     addStmtCtxt ((text "addArgCtxt last 2e")) stmt $
+                     addStmtCtxt ((text "addArgCtxt last 2e")) (unLoc stmt) $
                      thing_inside
 
-           VAExpansionStmt stmt@(BindStmt {}) loc
+           VAExpansionStmt stmt@(L _ BindStmt {}) loc
              -> do traceTc "addArgCtxt 2e bind" empty
                    setSrcSpan loc $
-                     -- (if in_generated_code && in_src_ctxt
-                     -- then
-                      addStmtCtxt ((text "addArgCtxt bind 2e")) stmt $
-                     --  else id) $
+                      addStmtCtxt ((text "addArgCtxt bind 2e")) (unLoc stmt) $
                      thing_inside
-           VAExpansionStmt (LetStmt {}) _
+           VAExpansionStmt (L _ LetStmt {}) _
              -> do traceTc "addArgCtxt 2e let" empty
                    thing_inside
            _ -> do traceTc "addArgCtxt 3" empty
                    setSrcSpanA arg_loc $
                      addExprCtxt (text "addArgCtxt 3") arg     $  -- Auto-suppressed if arg_loc is generated
                      thing_inside }
-  -- where
-  --   is_then_fun :: HsExpr GhcRn -> Bool
-  --   is_then_fun (HsVar _ (L _ f)) = f == thenMName
-  --   is_then_fun _ = False
-
-  --   is_bind_fun :: HsExpr GhcRn -> Bool
-  --   is_bind_fun (HsVar _ (L _ f)) = f == bindMName
-  --   is_bind_fun _ = False
-
-    -- mk_body_stmt :: HsExpr GhcRn -> ExprLStmt GhcRn
-    -- mk_body_stmt e = L arg_loc (BodyStmt noExtField (L arg_loc e) NoSyntaxExprRn NoSyntaxExprRn)
 
 
 {- *********************************************************************


=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -209,7 +209,7 @@ data AppCtxt
        SrcSpan           -- The SrcSpan of the expression
                          --    noSrcSpan if outermost; see Note [AppCtxt]
   | VAExpansionStmt
-       (ExprStmt GhcRn)    -- Inside an expansion of this do stmt
+       (ExprLStmt GhcRn)    -- Inside an expansion of this do stmt
        SrcSpan             -- location of this statement
 
   | VACall
@@ -329,9 +329,13 @@ splitHsApps e = go e (top_ctxt 0 e) []
       = go fun (VAExpansion orig (appCtxtLoc ctxt))
                (EWrap (EExpand orig) : args)
 
-    go (XExpr (ExpandedStmt (HsExpanded stmt fun))) _ args
-      = go fun (VAExpansionStmt (unLoc stmt) generatedSrcSpan)
-             (EWrap (EExpandStmt stmt) : args)
+    go (XExpr (ExpandedStmt (HsExpanded stmt@(L loc s) fun))) _ args
+      | BodyStmt{} <- s
+      = go fun (VAExpansionStmt stmt generatedSrcSpan)
+               (EWrap (EExpandStmt stmt) : args)
+      | otherwise
+      = go fun (VAExpansionStmt stmt (locA loc))
+               (EWrap (EExpandStmt stmt) : args)
 
     -- See Note [Desugar OpApp in the typechecker]
     go e@(OpApp _ arg1 (L l op) arg2) _ args
@@ -840,8 +844,8 @@ tcInferAppHead_maybe fun args
       _                         -> return Nothing
 
 addHeadCtxt :: AppCtxt -> TcM a -> TcM a
-addHeadCtxt (VAExpansionStmt stmt loc) thing_inside =
-  do setSrcSpan loc $
+addHeadCtxt (VAExpansionStmt (L loc stmt) _) thing_inside =
+  do setSrcSpanA loc $
        addStmtCtxt (text "addHeadCtxt") stmt
          thing_inside
 addHeadCtxt fun_ctxt thing_inside



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5916867163003619fe52b5c6730fbfcf37721bff
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/20230726/ab98ed97/attachment-0001.html>