[Git][ghc/ghc][wip/expansions-appdo] make applicative breakpoint work
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Tue Apr 2 23:09:52 UTC 2024
Apoorv Ingle pushed to branch wip/expansions-appdo at Glasgow Haskell Compiler / GHC
Commits:
f76e8cfd by Apoorv Ingle at 2024-04-02T18:09:39-05:00
make applicative breakpoint work
- - - - -
9 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Zonk/Type.hs
- compiler/Language/Haskell/Syntax/Expr.hs
- testsuite/tests/ghci.debugger/scripts/break029.stdout
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -476,7 +476,7 @@ type instance XXExpr GhcTc = XXExprGhcTc
-- | The different source constructs that we use to instantiate the "original" field
-- in an `XXExprGhcRn original expansion`
data HsThingRn = OrigExpr (HsExpr GhcRn)
- | OrigStmt (ExprLStmt GhcRn) HsDoFlavour
+ | OrigStmt (ExprLStmt GhcRn) HsDoFlavour -- ^ which kind of do-block did this statement come from
| OrigPat (LPat GhcRn) (Maybe (HsDoFlavour, ExprLStmt GhcRn))
isHsThingRnExpr, isHsThingRnStmt, isHsThingRnPat :: HsThingRn -> Bool
@@ -1794,7 +1794,7 @@ pprArg (ApplicativeArgMany _ stmts return pat ctxt) =
ppr pat <+>
text "<-" <+>
pprDo ctxt (stmts ++
- [noLocA (LastStmt noExtField (noLocA return) Nothing noSyntaxExpr)])
+ [noLocA (LastStmt noExtField return Nothing noSyntaxExpr)])
pprTransformStmt :: (OutputableBndrId p)
=> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -782,8 +782,8 @@ dsDo ctx stmts
do_arg (ApplicativeArgOne fail_op pat expr _) =
((pat, fail_op), dsLExpr expr)
- do_arg (ApplicativeArgMany _ stmts ret pat _) =
- ((pat, Nothing), dsDo ctx (stmts ++ [noLocA $ mkLastStmt (noLocA ret)]))
+ do_arg (ApplicativeArgMany _ stmts ret@(L ret_loc _) pat _) =
+ ((pat, Nothing), dsDo ctx (stmts ++ [L ret_loc $ mkLastStmt ret]))
; rhss' <- sequence rhss
=====================================
compiler/GHC/HsToCore/Ticks.hs
=====================================
@@ -774,7 +774,7 @@ addTickApplicativeArg isGuard (op, arg) =
addTickArg (ApplicativeArgMany x stmts ret pat ctxt) =
(ApplicativeArgMany x)
<$> addTickLStmts isGuard stmts
- <*> (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) ret))
+ <*> addTickLHsExpr ret
<*> addTickLPat pat
<*> pure ctxt
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -2230,12 +2230,12 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
(stmts',fvs2) <- stmtTreeToStmts monad_names ctxt tree [] pvarset
(mb_ret, fvs1) <-
if | L _ ApplicativeStmt{} <- last stmts' ->
- return (unLoc tup, emptyNameSet)
+ return (tup, emptyNameSet)
| otherwise -> do
-- Need 'pureAName' and not 'returnMName' here, so that it requires
-- 'Applicative' and not 'Monad' whenever possible (until #20540 is fixed).
(ret, _) <- lookupQualifiedDoExpr (HsDoStmt ctxt) pureAName
- let expr = HsApp noExtField (noLocA ret) tup
+ let expr = noLocA (HsApp noExtField (noLocA ret) tup)
return (expr, emptyFVs)
return ( ApplicativeArgMany
{ xarg_app_arg_many = noExtField
=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -21,7 +21,7 @@ module GHC.Tc.Gen.Do (expandDoStmts) where
import GHC.Prelude
-import GHC.Rename.Utils ( wrapGenSpan, genHsExpApps, genHsApp, genHsLet,
+import GHC.Rename.Utils ( wrapGenSpan, genHsExpApps, genHsApp, genHsLet, genLHsApp,
genHsLamDoExp, genHsCaseAltDoExp, genWildPat )
import GHC.Tc.Utils.Monad
import GHC.Tc.Gen.Pat
@@ -88,9 +88,9 @@ expand_do_stmts flav [stmt@(L loc (LastStmt _ (L body_loc body) _ ret_expr))]
-- Last statement is just body if we are not in ListComp context. See Syntax.Expr.LastStmt
= do appDo <- xoptM LangExt.ApplicativeDo
if appDo
- then do traceTc "expand_do_stmts last no pop" (ppr ret_expr)
+ then do traceTc "expand_do_stmts last no pop" (ppr $ (L body_loc body))
return $ mkExpandedStmtAt loc stmt flav body
- else do traceTc "expand_do_stmts last pop" (ppr ret_expr)
+ else do traceTc "expand_do_stmts last pop" (ppr $ (L body_loc body))
return $ mkExpandedStmtPopAt loc stmt flav body
| SyntaxExprRn ret <- ret_expr
@@ -191,17 +191,17 @@ expand_do_stmts doFlavour
-- and potentially loop forever
-expand_do_stmts doFlavour ((L loc (ApplicativeStmt _ args mb_join)): lstmts) =
+expand_do_stmts doFlavour ((L _ (ApplicativeStmt _ args mb_join)): lstmts) =
-- See Note [Applicative BodyStmt]
--
-- stmts ~~> stmts'
-- -------------------------------------------------------------------------
--- [(<$>, \ x -> e1), (<*>, e2), (<*>, e3), .. ] ; stmts ~~> (\ x -> stmts') <$> e1 <*> e2 ...
+-- [(fmap, \ x -> e1), (<*>, e2), (<*>, e3), .. ] ; stmts ~~> (\ x -> stmts') <$> e1 <*> e2 ...
--
-- Very similar to HsToCore.Expr.dsDo
-- args are [(<$>, e1), (<*>, e2), .., ]
- do { expr' <- unLoc <$> expand_do_stmts doFlavour lstmts
+ do { expr' <- expand_do_stmts doFlavour lstmts
-- extracts pats and arg bodies (rhss) from args
; (pats_can_fail, rhss) <- unzip <$> mapM (do_arg . snd) args
@@ -213,9 +213,10 @@ expand_do_stmts doFlavour ((L loc (ApplicativeStmt _ args mb_join)): lstmts) =
-- wrap the expanded expression with a `join` if needed
; let final_expr = case mb_join of
- Just (SyntaxExprRn join_op) -> wrapGenSpan $ genHsApp join_op (wrapGenSpan expand_ado_expr)
- _ -> L loc expand_ado_expr
+ Just (SyntaxExprRn join_op) -> genLHsApp join_op expand_ado_expr
+ _ -> expand_ado_expr
; traceTc "expand_do_stmts AppStmt" (vcat [ text "args:" <+> ppr args
+ , text "lstmts:" <+> ppr lstmts
, text "mb_join:" <+> ppr mb_join
, text "expansion:" <+> ppr final_expr])
; return final_expr
@@ -226,28 +227,34 @@ expand_do_stmts doFlavour ((L loc (ApplicativeStmt _ args mb_join)): lstmts) =
{ xarg_app_arg_one = mb_fail_op
, app_arg_pattern = pat
, arg_expr = (L rhs_loc rhs)
+ , is_body_stmt = is_body_stmt
}) =
- return ((pat, mb_fail_op)
- , mkExpandedStmtAt rhs_loc (L rhs_loc (BindStmt xbsn pat (L rhs_loc rhs))) doFlavour rhs)
- do_arg (ApplicativeArgMany _ stmts ret pat ctxt) =
- do { expr <- expand_do_stmts ctxt $ stmts ++ [wrapGenSpan $ mkLastStmt (wrapGenSpan ret)]
+ do traceTc "do_arg" (text "OneArg" <+> ppr (L rhs_loc rhs))
+ return ((pat, mb_fail_op)
+ , mkExpandedStmtAt rhs_loc stmt doFlavour rhs)
+ where stmt = if is_body_stmt
+ then (L rhs_loc (BodyStmt NoExtField (L rhs_loc rhs) NoSyntaxExprRn NoSyntaxExprRn))
+ else (L rhs_loc (BindStmt xbsn pat (L rhs_loc rhs)))
+ do_arg (ApplicativeArgMany _ stmts ret@(L ret_loc _) pat ctxt) =
+ do { expr <- expand_do_stmts ctxt $ stmts ++ [L ret_loc $ mkLastStmt ret]
; return ((pat, Nothing)
, expr) }
- match_args :: ((LPat GhcRn, FailOperator GhcRn), LHsExpr GhcRn) -> HsExpr GhcRn -> TcM (HsExpr GhcRn)
- match_args ((pat, fail_op), stmt_expr) body = unLoc <$> mk_failable_expr doFlavour stmt_ctxt pat (wrapGenSpan body) fail_op
+ match_args :: ((LPat GhcRn, FailOperator GhcRn), LHsExpr GhcRn) -> LHsExpr GhcRn -> TcM (LHsExpr GhcRn)
+ match_args ((pat, fail_op), stmt_expr) body = mk_failable_expr doFlavour stmt_ctxt pat body fail_op
where stmt_ctxt = case unLoc stmt_expr of
XExpr (ExpandedThingRn (OrigStmt s _) _) -> Just (doFlavour, s)
_ -> Nothing
- mk_apps :: HsExpr GhcRn -> (SyntaxExprRn, LHsExpr GhcRn) -> HsExpr GhcRn
+ mk_apps :: LHsExpr GhcRn -> (SyntaxExprRn, LHsExpr GhcRn) -> LHsExpr GhcRn
mk_apps l_expr (op, r_expr) =
case op of
SyntaxExprRn op -> case r_expr of
- L _ (XExpr (ExpandedThingRn (OrigStmt (L l s) flav) e)) -> XExpr (ExpandedThingRn (OrigStmt (L l s) flav)
- (genHsExpApps op [ wrapGenSpan l_expr
- , wrapGenSpan e ]))
- _ -> genHsExpApps op [ wrapGenSpan l_expr, r_expr ]
+ L loc (XExpr (ExpandedThingRn (OrigStmt (L l s) flav) e))
+ -> L loc $ XExpr (ExpandedThingRn (OrigStmt (L l s) flav)
+ (genHsExpApps op [ l_expr
+ , L loc e ]))
+ _ -> wrapGenSpan $ genHsExpApps op [ l_expr, r_expr ]
NoSyntaxExprRn -> pprPanic "expand_do_stmts applicative op:" (ppr op)
xbsn :: XBindStmtRn
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -1146,7 +1146,7 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside
= do { (stmts', (ret',pat')) <-
tcStmtsAndThen (HsDoStmt ctxt) tcDoStmt stmts (mkCheckExpType exp_ty) $
\res_ty -> do
- { ret' <- tcExpr ret res_ty
+ { ret' <- tcMonoExprNC ret res_ty
; (pat', _) <- tcCheckPat (StmtCtxt (HsDoStmt ctxt)) pat (unrestricted pat_ty) $
return ()
; return (ret', pat')
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -1453,7 +1453,7 @@ zonkStmt _zBody (ApplicativeStmt body_ty args mb_join)
; return (ApplicativeArgOne new_fail pat new_expr isBody) }
zonk_arg (ApplicativeArgMany x stmts ret pat ctxt)
= runZonkBndrT (zonkStmts zonkLExpr stmts) $ \ new_stmts ->
- do { new_ret <- zonkExpr ret
+ do { new_ret <- zonkLExpr ret
; return (ApplicativeArgMany x new_stmts new_ret pat ctxt) }
-------------------------------------------------------------------------
=====================================
compiler/Language/Haskell/Syntax/Expr.hs
=====================================
@@ -1271,7 +1271,7 @@ data ApplicativeArg idL
| ApplicativeArgMany -- do { stmts; return vars }
{ xarg_app_arg_many :: XApplicativeArgMany idL
, app_stmts :: [ExprLStmt idL] -- stmts
- , final_expr :: HsExpr idL -- return (v1,..,vn), or just (v1,..,vn)
+ , final_expr :: LHsExpr idL -- return (v1,..,vn), or just (v1,..,vn)
, bv_pattern :: LPat idL -- (v1,...,vn)
, stmt_context :: HsDoFlavour
-- ^ context of the do expression, used in pprArg
=====================================
testsuite/tests/ghci.debugger/scripts/break029.stdout
=====================================
@@ -4,7 +4,7 @@ x :: Int = 3
Stopped in Main.f, break029.hs:5:8-21
_result :: IO Int = _
x :: Int = 3
-Stopped in Main.f, break029.hs:6:11-15
+Stopped in Main.f, break029.hs:6:3-16
_result :: Int = _
y :: Int = _
4
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f76e8cfdb0cb7780828257fab5990a404325dbee
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f76e8cfdb0cb7780828257fab5990a404325dbee
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/20240402/5de23309/attachment-0001.html>
More information about the ghc-commits
mailing list