[Git][ghc/ghc][wip/expand-do] add PopSrcSpan in appropriate places while desugaring

[Apoorv Ingle (@ani)]

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


Commits:
e54201aa by Apoorv Ingle at 2023-05-22T12:51:39-05:00
add PopSrcSpan in appropriate places while desugaring

- - - - -


2 changed files:

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


Changes:

=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -476,6 +476,12 @@ mkExpandedExpr
   -> HsExpr GhcRn           -- ^ suitably wrapped 'HsExpansion'
 mkExpandedExpr a b = XExpr (ExpansionExprRn (HsExpanded (Left a) b))
 
+mkExpandedStmt
+  :: ExprLStmt GhcRn        -- ^ source statement
+  -> HsExpr GhcRn           -- ^ expanded expression
+  -> HsExpr GhcRn           -- ^ suitably wrapped 'HsExpansion'
+mkExpandedStmt a b = XExpr (ExpansionExprRn (HsExpanded (Right a) b))
+
 data XXExprGhcTc
   = WrapExpr        -- Type and evidence application and abstractions
       {-# UNPACK #-} !(HsWrap HsExpr)
@@ -740,7 +746,8 @@ ppr_expr (XExpr x) = case ghcPass @p of
   GhcTc -> ppr x
 
 instance Outputable XXExprGhcRn where
-  ppr (ExpansionExprRn e) = ppr e
+  ppr (ExpansionExprRn (HsExpanded (Left e) _)) = ppr e
+  ppr (ExpansionExprRn (HsExpanded (Right e) _)) = ppr e
   ppr (PopSrcSpan e) = ppr e
 
 


=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -1209,7 +1209,7 @@ expand_do_stmts _ [L _ (LastStmt _ body _ ret_expr)]
    = return $ wrapGenSpan $ genHsApp ret body
 
 
-expand_do_stmts do_or_lc ((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 x can fail
@@ -1220,10 +1220,10 @@ expand_do_stmts do_or_lc ((L _ (BindStmt xbsrn pat e)): lstmts)
 --       pat <- e ; stmts   ~~> (>>=) e f
       do expand_stmts <- expand_do_stmts do_or_lc lstmts
          expr <- mk_failable_lexpr_tcm pat expand_stmts fail_op
-         return $ mkHsApps (wrapGenSpan bind_op)-- (>>=)
-                                [ e
-                                , expr
-                                ]
+         return $ mkHsApps (wrapGenSpan bind_op)  -- (>>=)
+                      [ e
+                      , noLocA $ mkPopSrcSpanExpr expr
+                      ]
 
   | otherwise = -- just use the Prelude.>>= TODO: Necessary?
 --                          stmts ~~> stmts'
@@ -1241,7 +1241,7 @@ expand_do_stmts do_or_lc (L _ (LetStmt _ bnds) : lstmts) =
 --    ------------------------------------------------
 --       let x = e ; stmts ~~> let x = e in stmts'
   do expand_stmts <- expand_do_stmts do_or_lc lstmts
-     return $ wrapGenSpan (HsLet noExtField noHsTok bnds noHsTok (expand_stmts))
+     return $ wrapGenSpan (HsLet noExtField noHsTok bnds noHsTok (noLocA $ mkPopSrcSpanExpr expand_stmts))
 
 
 expand_do_stmts do_or_lc ((L loc (BodyStmt _ e (SyntaxExprRn f) _)) : lstmts) =
@@ -1250,9 +1250,9 @@ expand_do_stmts do_or_lc ((L loc (BodyStmt _ e (SyntaxExprRn f) _)) : lstmts) =
 --    ----------------------------------------------
 --      e ; stmts ~~> (>>) e stmts'
   do expand_stmts <- expand_do_stmts do_or_lc lstmts
-     return $ L loc (mkPopSrcSpanExpr (mkHsApps (wrapGenSpan f) -- (>>)
-                                   [ e               -- e
-                                   , expand_stmts ]))  -- stmts'
+     return $ (mkHsApps (wrapGenSpan f) -- (>>)
+                [ e               -- e
+                , noLocA $ mkPopSrcSpanExpr expand_stmts ])  -- stmts'
 
 expand_do_stmts do_or_lc
   ((L _ (RecStmt { recS_stmts = rec_stmts



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e54201aa253eab119d4b0ed0829d3cc3ce4f3f85
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/20230522/2b72c417/attachment-0001.html>