[Git][ghc/ghc][wip/expand-do] break at HsCase as it may occur inside a body stmt

[Apoorv Ingle (@ani)]

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


Commits:
eaa104f7 by Apoorv Ingle at 2023-10-02T00:27:46-05:00
break at HsCase as it may occur inside a body stmt

- - - - -


1 changed file:

- compiler/GHC/HsToCore/Ticks.hs


Changes:

=====================================
compiler/GHC/HsToCore/Ticks.hs
=====================================
@@ -445,11 +445,13 @@ isGoodBreakExpr e = isCallSite e
 isCallSite :: HsExpr GhcTc -> Bool
 isCallSite HsApp{}     = True
 isCallSite HsAppType{} = True
+isCallSite HsCase{}    = True
 isCallSite (XExpr (ExpansionExpr (HsExpanded _ e)))
                        = isCallSite e
-isCallSite (XExpr (ExpansionStmt (HsExpanded (L _ stmt) _)))
+isCallSite (XExpr (ExpansionStmt (HsExpanded (L _ stmt) e)))
   | BodyStmt{} <- stmt = False
-  | otherwise          = True
+  | LastStmt{} <- stmt = True
+  | otherwise          = isCallSite e
 
 -- NB: OpApp, SectionL, SectionR are all expanded out
 isCallSite _           = False
@@ -523,6 +525,7 @@ addTickHsExpr (HsCase x e mgs) =
                 (addTickLHsExpr e) -- not an EvalInner; e might not necessarily
                                    -- be evaluated.
                 (addTickMatchGroup False mgs)
+
 addTickHsExpr (HsIf x e1 e2 e3) =
         liftM3 (HsIf x)
                 (addBinTickLHsExpr (BinBox CondBinBox) e1)
@@ -624,11 +627,11 @@ addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc)
                   -> TM (MatchGroup GhcTc (LHsExpr GhcTc))
 addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches, mg_ext = ctxt }) = do
   let isOneOfMany = matchesOneOfMany matches
-      isDoExpansionStmt = isJust (isDoExpansionGenerated $ mg_origin ctxt)
-  matches' <- mapM (traverse (addTickMatch isOneOfMany is_lam isDoExpansionStmt)) matches
+      isDoExp     = isJust (isDoExpansionGenerated $ mg_origin ctxt)
+  matches' <- mapM (traverse (addTickMatch isOneOfMany is_lam isDoExp)) matches
   return $ mg { mg_alts = L l matches' }
 
-addTickMatch :: Bool -> Bool -> Bool -> Match GhcTc (LHsExpr GhcTc)
+addTickMatch :: Bool -> Bool -> Bool {-Is Do Expanion-} ->  Match GhcTc (LHsExpr GhcTc)
              -> TM (Match GhcTc (LHsExpr GhcTc))
 addTickMatch isOneOfMany isLambda isDoExp match@(Match { m_pats = pats
                                                        , m_grhss = gRHSs }) =



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

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