[Git][ghc/ghc][wip/expand-do] 2 commits: add location information for last statements

[Apoorv Ingle (@ani)]

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


Commits:
5974b668 by Apoorv Ingle at 2023-06-05T16:14:38-05:00
add location information for last statements

- - - - -
25c5c258 by Apoorv Ingle at 2023-06-05T17:59:52-05:00
do not pop context while checking the second argument to expanded (>>)

- - - - -


3 changed files:

- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Types/Origin.hs


Changes:

=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -209,14 +209,16 @@ tcExpr e@(ExprWithTySig {})      res_ty = tcApp e res_ty
 tcExpr e@(HsRecSel {})           res_ty = tcApp e res_ty
 tcExpr e@(XExpr (ExpandedExpr {})) res_ty = tcApp e res_ty
 
-tcExpr (XExpr (PopSrcSpan e)) res_ty = popErrCtxt $ tcExpr (unLoc e) res_ty
+tcExpr (XExpr (PopSrcSpan e)) res_ty = do
+  do popErrCtxt $ tcExpr (unLoc e) res_ty -- needs to do more intelligent popping
 
 tcExpr (XExpr (ExpandedStmt (HsExpanded stmt expr))) res_ty
   =  do { traceTc "tcDoStmts" (vcat [ text "stmt:" <+> ppr stmt
                                     , text "expr:" <+> ppr expr
-                                    , text "res_ty" <+> ppr res_ty
+                                    , text "res_ty:" <+> ppr res_ty
                                     ])
-        ; tcExpr (unLoc expr) res_ty
+        ; addErrCtxt (pprStmtInCtxt @Renamed @Renamed @Renamed (HsDoStmt (DoExpr Nothing)) (unLoc stmt)) $
+          tcExpr (unLoc expr) res_ty
         }
 
 


=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -1187,11 +1187,11 @@ checkArgCounts matchContext (MG { mg_alts = L _ (match1:matches) })
 genPopSrcSpanExpr :: LHsExpr GhcRn -> LHsExpr GhcRn
 genPopSrcSpanExpr = wrapGenSpan . mkPopSrcSpanExpr
 
-mkExpandedStmtLExpr
-  :: ExprLStmt GhcRn        -- ^ source statement
-  -> LHsExpr GhcRn          -- ^ expanded expression
-  -> LHsExpr GhcRn           -- ^ suitably wrapped 'HsExpansion'
-mkExpandedStmtLExpr a b = noLocA $ mkExpandedStmt a b
+-- mkExpandedStmtLExpr
+--   :: ExprLStmt GhcRn        -- ^ source statement
+--   -> LHsExpr GhcRn          -- ^ expanded expression
+--   -> LHsExpr GhcRn           -- ^ suitably wrapped 'HsExpansion'
+-- mkExpandedStmtLExpr a b = noLocA $ mkExpandedStmt a b
 
 expandDoStmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn)
 expandDoStmts = expand_do_stmts
@@ -1218,7 +1218,7 @@ expand_do_stmts _ [stmt@(L loc (LastStmt _ body _ ret_expr))]
   -- See `checkLastStmt` and `Syntax.Expr.StmtLR.LastStmt`
    | NoSyntaxExprRn <- ret_expr
    -- Last statement is just body if we are not in ListComp context. See Syntax.Expr.LastStmt
-   = return $ mkExpandedStmtLExpr stmt body
+   = return $ L loc (mkExpandedStmt stmt body)
 
    | SyntaxExprRn ret <- ret_expr
    --
@@ -1226,7 +1226,7 @@ expand_do_stmts _ [stmt@(L loc (LastStmt _ body _ ret_expr))]
    --               return e  ~~> return e
    -- to make T18324 work
    = return $ L loc (mkExpandedStmt stmt
-                        ((L loc (genHsApp ret body))))
+                        ((L loc (HsApp noAnn (L loc ret) body))))
 
 
 expand_do_stmts do_or_lc (stmt@(L loc (LetStmt _ bnds)) : lstmts) =
@@ -1251,7 +1251,7 @@ expand_do_stmts do_or_lc (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
          expr <- mk_failable_lexpr_tcm pat expand_stmts fail_op
          return $ (mkHsApps (wrapGenSpan bind_op)  -- (>>=)
                              [ L loc (mkPopSrcSpanExpr $ L loc (mkExpandedStmt stmt e))
-                             , genPopSrcSpanExpr expr
+                             , expr
                              ])
 
   | otherwise = pprPanic "expand do: shouldn't happen"  (text "stmt" <+> ppr  stmt)
@@ -1264,7 +1264,7 @@ expand_do_stmts do_or_lc (stmt@(L loc (BodyStmt _ e (SyntaxExprRn f) _)) : lstmt
   do expand_stmts <- expand_do_stmts do_or_lc lstmts
      return $ (mkHsApps (wrapGenSpan f) -- (>>)
                 [ L loc (mkPopSrcSpanExpr $ L loc (mkExpandedStmt stmt e)) -- e
-                , genPopSrcSpanExpr expand_stmts ])  -- stmts'
+                , expand_stmts ])  -- stmts'
 
 expand_do_stmts do_or_lc
   ((L do_loc (RecStmt { recS_stmts = L stmts_loc rec_stmts


=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -1380,11 +1380,12 @@ pprExpectedFunTyOrigin funTy_origin i =
            , nest 2 (ppr expr) ]
     ExpectedFunTyArg fun arg -> case arg of
                                   XExpr (PopSrcSpan (L _ (XExpr (ExpandedStmt (HsExpanded {}))))) ->
+                                    -- likey an expanded statement
                                     vcat [ sep [ the_arg_of
                                                , text "the rebindable syntax operator"
                                                , quotes (ppr fun)
                                                ]
-                                         , nest 2 (text "arising from a do stmt")
+                                         , nest 2 (text "arising from a do statement")
                                          ]
                                   _ -> sep [ text "The argument"
                                            , quotes (ppr arg)



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/265cc4fd5cab792f22121bdafdc047e13fb1f374...25c5c258914627551a26a0764e693157cf10cd81

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/265cc4fd5cab792f22121bdafdc047e13fb1f374...25c5c258914627551a26a0764e693157cf10cd81
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/20230605/5965c752/attachment-0001.html>