[Git][ghc/ghc][wip/spj-apporv-Oct24] push unLocs further in
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Tue Dec 10 18:20:24 UTC 2024
Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC
Commits:
9bb3b929 by Apoorv Ingle at 2024-12-10T12:18:55-06:00
push unLocs further in
- - - - -
5 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -548,7 +548,7 @@ data XXExprGhcRn
}
| PopErrCtxt -- A hint for typechecker to pop
- {-# UNPACK #-} !(HsExpr GhcRn) -- the top of the error context stack
+ {-# UNPACK #-} !(HsExpr GhcRn) -- the top of the error context stack
-- Does not presist post renaming phase
-- See Part 3. of Note [Expanding HsDo with XXExprGhcRn]
-- in `GHC.Tc.Gen.Do`
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -909,23 +909,6 @@ addArgCtxt ctxt (L arg_loc arg) thing_inside
addErrCtxt (funAppCtxt fun arg arg_no) $
thing_inside
-{-
- VAExpansion (OrigStmt (L _ stmt@(BindStmt {})) flav) _ loc
- | isGeneratedSrcSpan (locA arg_loc) -- This arg is the second argument to generated (>>=)
- -> setSrcSpan loc $
- addStmtCtxt stmt flav $
- thing_inside
- | otherwise -- This arg is the first argument to generated (>>=)
- -> setSrcSpanA arg_loc $
- addStmtCtxt stmt flav $
- thing_inside
- VAExpansion (OrigStmt (L _ (XStmtLR (ApplicativeStmt{}))) _) _ _
- -> thing_inside
- VAExpansion (OrigStmt (L loc stmt) flav) _ _
- -> setSrcSpanA loc $
- addStmtCtxt stmt flav $
- thing_inside
--}
_ -> setSrcSpanA arg_loc $
addExprCtxt arg $ -- Auto-suppressed if arg_loc is generated
thing_inside }
=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -47,17 +47,16 @@ import Data.List ((\\))
* *
************************************************************************
-}
--- TODO: make caller add the pop error context
-- | Expand the `do`-statments into expressions right after renaming
-- so that they can be typechecked.
-- See Note [Expanding HsDo with XXExprGhcRn] below for `HsDo` specific commentary
-- and Note [Handling overloaded and rebindable constructs] for high level commentary
expandDoStmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (HsExpr GhcRn)
-expandDoStmts doFlav stmts = unLoc <$> expand_do_stmts doFlav stmts
+expandDoStmts doFlav stmts = expand_do_stmts doFlav stmts
-- | The main work horse for expanding do block statements into applications of binds and thens
-- See Note [Expanding HsDo with XXExprGhcRn]
-expand_do_stmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn)
+expand_do_stmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (HsExpr GhcRn)
expand_do_stmts ListComp _ =
pprPanic "expand_do_stmts: impossible happened. ListComp" empty
@@ -73,13 +72,13 @@ expand_do_stmts _ (stmt@(L _ (ParStmt {})):_) =
expand_do_stmts _ [] = pprPanic "expand_do_stmts: impossible happened. Empty stmts" empty
-expand_do_stmts flav [stmt@(L loc (LastStmt _ (L body_loc body) _ ret_expr))]
+expand_do_stmts flav [stmt@(L _loc (LastStmt _ (L body_loc body) _ ret_expr))]
-- See Note [Expanding HsDo with XXExprGhcRn] Equation (5) below
-- last statement of a list comprehension, needs to explicitly return it
-- 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 $ mkExpandedStmtAt loc stmt flav body
+ = return $ mkExpandedStmt stmt flav body
| SyntaxExprRn ret <- ret_expr
--
@@ -87,16 +86,16 @@ expand_do_stmts flav [stmt@(L loc (LastStmt _ (L body_loc body) _ ret_expr))]
-- return e ~~> return e
-- to make T18324 work
= do let expansion = genHsApp ret (L body_loc body)
- return $ mkExpandedStmtAt body_loc stmt flav expansion
+ return $ mkExpandedStmt stmt flav expansion
expand_do_stmts doFlavour (stmt@(L _ (LetStmt _ bs)) : lstmts) =
-- See Note [Expanding HsDo with XXExprGhcRn] Equation (3) below
-- stmts ~~> stmts'
-- ------------------------------------------------
-- let x = e ; stmts ~~> let x = e in stmts'xo
- do expand_stmts <- expand_do_stmts doFlavour lstmts
- let expansion = genHsLet bs (genPopErrCtxtExpr . unLoc $ expand_stmts)
- return $ mkExpandedStmtAt (noAnnSrcSpan generatedSrcSpan) stmt doFlavour expansion
+ do expand_stmts_expr <- expand_do_stmts doFlavour lstmts
+ let expansion = genHsLet bs (genPopErrCtxtExpr expand_stmts_expr)
+ return $ mkExpandedStmt stmt doFlavour expansion
expand_do_stmts doFlavour (stmt@(L _loc (BindStmt xbsrn pat e)): lstmts)
| SyntaxExprRn bind_op <- xbsrn_bindOp xbsrn
@@ -107,12 +106,12 @@ expand_do_stmts doFlavour (stmt@(L _loc (BindStmt xbsrn pat e)): lstmts)
-- _ -> fail "Pattern match failure .."
-- -------------------------------------------------------
-- pat <- e ; stmts ~~> (>>=) e f
- = do expand_stmts <- expand_do_stmts doFlavour lstmts
- failable_expr <- mk_failable_expr doFlavour pat (genPopErrCtxtExpr . unLoc $ expand_stmts) fail_op
+ = do expand_stmts_expr <- expand_do_stmts doFlavour lstmts
+ failable_expr <- mk_failable_expr doFlavour pat (genPopErrCtxtExpr expand_stmts_expr) fail_op
let expansion = genHsExpApps bind_op -- (>>=)
[ e
, failable_expr ]
- return $ mkExpandedStmtAt (noAnnSrcSpan generatedSrcSpan) stmt doFlavour expansion
+ return $ mkExpandedStmt stmt doFlavour expansion
| otherwise
= pprPanic "expand_do_stmts: The impossible happened, missing bind operator from renamer" (text "stmt" <+> ppr stmt)
@@ -126,8 +125,8 @@ expand_do_stmts doFlavour (stmt@(L _loc (BodyStmt _ e (SyntaxExprRn then_op) _))
do expand_stmts_expr <- expand_do_stmts doFlavour lstmts
let expansion = genHsExpApps then_op -- (>>)
[ e
- , genPopErrCtxtExpr . unLoc $ expand_stmts_expr ]
- return $ mkExpandedStmtAt (noAnnSrcSpan generatedSrcSpan) stmt doFlavour expansion
+ , genPopErrCtxtExpr $ expand_stmts_expr ]
+ return $ mkExpandedStmt stmt doFlavour expansion
expand_do_stmts doFlavour
((L loc (RecStmt { recS_stmts = L stmts_loc rec_stmts
@@ -149,14 +148,14 @@ expand_do_stmts doFlavour
-- -> do { rec_stmts
-- ; return (local_only_ids ++ later_ids) } ))
-- (\ [ local_only_ids ++ later_ids ] -> stmts')
- do expand_stmts <- expand_do_stmts doFlavour lstmts
+ do expand_stmts_expr <- expand_do_stmts doFlavour lstmts
-- NB: No need to wrap the expansion with an ExpandedStmt
-- as we want to flatten the rec block statements into its parent do block anyway
- return $ mkHsApps (wrapGenSpan bind_fun) -- (>>=)
- [ (wrapGenSpan mfix_fun) `mkHsApp` mfix_expr -- (mfix (do block))
- , genHsLamDoExp doFlavour [ mkBigLHsVarPatTup all_ids ] -- (\ x ->
- expand_stmts -- stmts')
- ]
+ return $ unLoc (mkHsApps (wrapGenSpan bind_fun) -- (>>=)
+ [ (wrapGenSpan mfix_fun) `mkHsApp` mfix_expr -- (mfix (do block))
+ , genHsLamDoExp doFlavour [ mkBigLHsVarPatTup all_ids ] -- (\ x ->
+ (wrapGenSpan expand_stmts_expr) -- stmts')
+ ])
where
local_only_ids = local_ids \\ later_ids -- get unique local rec ids;
-- local rec ids and later ids can overlap
@@ -193,7 +192,7 @@ expand_do_stmts doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join))): lst
; (pats_can_fail, rhss) <- unzip <$> mapM (do_arg . snd) args
-- add blocks for failable patterns
- ; body_with_fails <- foldrM match_args xexpr pats_can_fail
+ ; body_with_fails <- foldrM match_args (wrapGenSpan xexpr) pats_can_fail
-- builds (((body <$> e1) <*> e2) ...)
; let expand_ado_expr = foldl mk_apps body_with_fails (zip (map fst args) rhss)
@@ -207,7 +206,7 @@ expand_do_stmts doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join))): lst
, text "lstmts:" <+> ppr lstmts
, text "mb_join:" <+> ppr mb_join
, text "expansion:" <+> ppr final_expr])
- ; return final_expr
+ ; return $ unLoc final_expr
}
where
@@ -225,7 +224,7 @@ expand_do_stmts doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join))): lst
, final_expr = ret@(L ret_loc _)
, bv_pattern = pat
, stmt_context = ctxt }) =
- do { xx_expr <- (wrapGenSpan . unLoc) <$> (expand_do_stmts ctxt $ stmts ++ [L ret_loc $ mkLastStmt ret])
+ do { xx_expr <- wrapGenSpan <$> (expand_do_stmts ctxt $ stmts ++ [L ret_loc $ mkLastStmt ret])
; traceTc "do_arg" (text "ManyArg" <+> ppr False <+> vcat [ppr (stmts ++ [L ret_loc $ mkLastStmt ret]), text "--", ppr xx_expr])
; return ((pat, Nothing)
, xx_expr) }
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -715,7 +715,8 @@ tcXExpr (PopErrCtxt e) res_ty
tcXExpr (ExpandedThingRn o@(OrigStmt stmt flav) e) res_ty
= addThingCtxt o $
- mkExpandedStmtTc stmt flav <$> tcExpr e res_ty
+ mkExpandedStmtTc stmt flav <$>
+ tcExpr e res_ty
-- For record selection
tcXExpr xe res_ty = tcApp (XExpr xe) res_ty
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -259,7 +259,7 @@ instance Outputable QLFlag where
ppr NoQL = text "NoQL"
instance Outputable AppCtxt where
- ppr (VAExpansion e l _) = text "VAExpansion" <+> ppr e <+> ppr l
+ ppr (VAExpansion e l l') = text "VAExpansion" <+> ppr e <+> ppr l <+> ppr l'
ppr (VACall f n l) = text "VACall" <+> int n <+> ppr f <+> ppr l
type family XPass (p :: TcPass) where
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9bb3b9293bebeda5801617bdf90e934c27395408
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9bb3b9293bebeda5801617bdf90e934c27395408
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/20241210/d475ed1d/attachment-0001.html>
More information about the ghc-commits
mailing list