[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:
9f2d8231 by Apoorv Ingle at 2023-05-22T13:42:09-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
=====================================
@@ -457,8 +457,10 @@ type instance XXExpr GhcTc = XXExprGhcTc
 type HsExprOrStmt a = Either (HsExpr a) (ExprLStmt a)
 
 data XXExprGhcRn
-  = ExpansionExprRn !(HsExpansion (HsExprOrStmt GhcRn) (HsExpr GhcRn))
-  | PopSrcSpan !(LHsExpr GhcRn)
+  = ExpansionExprRn
+    {-# UNPACK #-} !(HsExpansion (HsExprOrStmt GhcRn) (HsExpr GhcRn))
+  | PopSrcSpan
+    {-# UNPACK #-} !(LHsExpr GhcRn)
   -- Placeholder for identifying generated source locations in GhcRn phase
   -- Should not presist post typechecking
   -- Note [Desugaring Do with HsExpansion] in GHC.Tc.Gen.Match
@@ -476,6 +478,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 +748,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
=====================================
@@ -1220,17 +1220,16 @@ 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'
 --    -------------------------------------------------------
 --       pat <- e ; stmts   ~~> (Prelude.>>=) e (\ pat -> stmts')
-      do traceTc "expand_do_stmts: generic binop" empty
-         expand_stmts <- expand_do_stmts do_or_lc lstmts
+      do expand_stmts <- expand_do_stmts do_or_lc lstmts
          return $ mkHsApps  (genLHsVar bindMName) -- (Prelude.>>=)
                             [ e
                             , mkHsLamDoExp [pat] (noLocA $ mkPopSrcSpanExpr expand_stmts)  -- (\ x -> stmts')
@@ -1241,18 +1240,18 @@ 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) =
+expand_do_stmts do_or_lc ((L _ (BodyStmt _ e (SyntaxExprRn f) _)) : lstmts) =
 -- See Note [BodyStmt]
 --              stmts ~~> stmts'
 --    ----------------------------------------------
 --      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/9f2d8231e64478037f815f13141c8bafe27f6bc4

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9f2d8231e64478037f815f13141c8bafe27f6bc4
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/ab5ddac2/attachment-0001.html>