[Git][ghc/ghc][wip/expand-do] add PopSrcSpan in appropriate places while desugaring
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Tue May 23 01:13:31 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
e62da3f4 by Apoorv Ingle at 2023-05-22T20:13:16-05:00
add PopSrcSpan in appropriate places while desugaring
- - - - -
3 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/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
@@ -467,6 +469,10 @@ data XXExprGhcRn
mkPopSrcSpanExpr :: LHsExpr GhcRn -> HsExpr GhcRn
mkPopSrcSpanExpr a = XExpr (PopSrcSpan a)
+-- | Generated location for PopSrcExpr
+genPopSrcSpanExpr :: LHsExpr GhcRn -> LHsExpr GhcRn
+genPopSrcSpanExpr = noLocA . mkPopSrcSpanExpr
+
-- | Build a 'HsExpansion' out of an extension constructor,
-- and the two components of the expansion: original and
-- desugared expressions.
@@ -476,6 +482,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 +752,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/HsToCore/Expr.hs
=====================================
@@ -858,7 +858,8 @@ warnUnusedBindValue :: LHsExpr GhcTc -> LHsExpr GhcTc -> Type -> DsM ()
warnUnusedBindValue fun arg arg_ty
| Just (l, f) <- fish_var fun
, f `hasKey` thenMClassOpKey -- it is a (>>)
- , isGeneratedSrcSpan l -- it is compiler generated
+ , isNoSrcSpan l || isGeneratedSrcSpan l -- it is compiler generated
+ -- TODO: check why is isGeneratedSrcSpan false?
= do tracePm "warnUnusedBindValue" (vcat [ text "fun" <+> ppr fun
, text "loc" <+> ppr l
, text "locGen?" <+> ppr (isGeneratedSrcSpan l)
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -1192,7 +1192,7 @@ expand_do_stmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn)
expand_do_stmts ListComp _ = pprPanic "expand_do_stmts: impossible happened. ListComp" empty
expand_do_stmts _ [] = pprPanic "expand_do_stmts: impossible happened. Empty stmts" empty
-expand_do_stmts _ [L _ (LastStmt _ body _ ret_expr)]
+expand_do_stmts _ [L loc (LastStmt _ body _ ret_expr)]
-- last statement of a list comprehension, needs to explicitly return it
-- See `checkLastStmt` and `Syntax.Expr.StmtLR.LastStmt`
-- TODO: i don't think we need this if we never call from a ListComp
@@ -1206,53 +1206,44 @@ expand_do_stmts _ [L _ (LastStmt _ body _ ret_expr)]
-- ------------------------------------------------
-- return e ~~> return e
-- to make T18324 work
- = return $ wrapGenSpan $ genHsApp ret body
+ = return $ L loc (genHsApp ret body)
-expand_do_stmts do_or_lc ((L _ (BindStmt xbsrn pat e)): lstmts)
+expand_do_stmts do_or_lc (stmt@(L _ (BindStmt xbsrn pat e)): lstmts)
| SyntaxExprRn bind_op <- xbsrn_bindOp xbsrn
, fail_op <- xbsrn_failOp xbsrn =
-- the pattern binding x can fail
-- instead of making an internal name, the fail block is just an anonymous match block
--- stmts ~~> stmt' let / pat = stmts';
--- _ = fail "Pattern match failure .."
+-- stmts ~~> stmt' expr = let / pat = stmts';
+-- _ = fail "Pattern match failure .."
-- -------------------------------------------------------
--- pat <- e ; stmts ~~> (>>=) e f
+-- pat <- e ; stmts ~~> (>>=) expr 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
+ , genPopSrcSpanExpr 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
- return $ mkHsApps (genLHsVar bindMName) -- (Prelude.>>=)
- [ e
- , mkHsLamDoExp [pat] (noLocA $ mkPopSrcSpanExpr expand_stmts) -- (\ x -> stmts')
- ]
+ | otherwise = pprPanic "expand do: shouldn't happen" (text "stmt" <+> ppr stmt)
expand_do_stmts do_or_lc (L _ (LetStmt _ bnds) : lstmts) =
-- stmts ~~> stmts'
-- ------------------------------------------------
-- 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 (genPopSrcSpanExpr 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
+ , genPopSrcSpanExpr expand_stmts ]) -- stmts'
expand_do_stmts do_or_lc
((L _ (RecStmt { recS_stmts = rec_stmts
@@ -1276,7 +1267,7 @@ expand_do_stmts do_or_lc
return $ mkHsApps (genLHsVar bindMName) -- (Prelude.>>=)
[ (wrapGenSpan mfix_fun) `mkHsApp` mfix_expr -- (mfix (do block))
, mkHsLamDoExp [ mkBigLHsVarPatTup all_ids ] -- (\ x ->
- (noLocA $ mkPopSrcSpanExpr expand_stmts) -- stmts')
+ (genPopSrcSpanExpr expand_stmts) -- stmts')
]
where
local_only_ids = local_ids \\ later_ids -- get unique local rec ids;
@@ -1360,15 +1351,15 @@ mk_failable_lexpr_tcm :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> Tc
mk_failable_lexpr_tcm pat lexpr fail_op =
do { tc_env <- getGblEnv
; is_strict <- xoptM LangExt.Strict
- ; b <- isIrrefutableHsPatRn tc_env is_strict pat
+ ; irrf_pat <- isIrrefutableHsPatRn tc_env is_strict pat
; traceTc "mk_fail_lexpr_tcm" (vcat [ ppr pat
- , text "isIrrefutable:" <+> ppr b
+ , text "isIrrefutable:" <+> ppr irrf_pat
])
- ; if b
+ ; if irrf_pat
-- don't decorate with fail statement if
-- the pattern is irrefutable
- then return $ mkHsLamDoExp [pat] (noLocA (mkPopSrcSpanExpr lexpr))
+ then return $ mkHsLamDoExp [pat] (genPopSrcSpanExpr lexpr)
else mk_fail_lexpr pat lexpr fail_op
}
@@ -1379,8 +1370,8 @@ mk_fail_lexpr :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsEx
mk_fail_lexpr pat lexpr (Just (SyntaxExprRn fail_op)) =
do dflags <- getDynFlags
return $ noLocA (HsLam noExtField $ mkMatchGroup (Generated DoExpansion) -- \
- (noLocA [ mkHsCaseAlt pat (noLocA $ mkPopSrcSpanExpr lexpr) -- pat -> expr
- , mkHsCaseAlt nlWildPatName -- _ -> fail "fail pattern"
+ (noLocA [ mkHsCaseAlt pat (genPopSrcSpanExpr lexpr) -- pat -> expr
+ , mkHsCaseAlt nlWildPatName -- _ -> fail "fail pattern"
(noLocA $ genHsApp fail_op
(mk_fail_msg_expr dflags (DoExpr Nothing) pat))
]))
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e62da3f4897555fe49ad30b9110bd4bb932cdc67
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e62da3f4897555fe49ad30b9110bd4bb932cdc67
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/f4c61c11/attachment-0001.html>
More information about the ghc-commits
mailing list