[Git][ghc/ghc][wip/expand-do] PopSrcSpan in HsExpr
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Mon May 1 07:27:36 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
370f8052 by Apoorv Ingle at 2023-05-01T02:26:54-05:00
PopSrcSpan in HsExpr
- - - - -
10 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Syn/Type.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Utils/Zonk.hs
- compiler/Language/Haskell/Syntax/Expr.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -726,6 +726,12 @@ ppr_expr (XExpr x) = case ghcPass @p of
GhcRn -> ppr x
GhcTc -> ppr x
+ppr_expr (PopSrcSpan x) = case ghcPass @p of
+ GhcPs -> panic "ppr_expr Ps HsPopSrcSpan"
+ GhcRn -> ppr x
+ GhcTc -> panic "ppr_expr Tc HsPopSrcSpan"
+
+
instance Outputable XXExprGhcTc where
ppr (WrapExpr (HsWrap co_fn e))
= pprHsWrapper co_fn (\_parens -> pprExpr e)
@@ -845,6 +851,7 @@ hsExprNeedsParens prec = go
go (HsDo _ sc _)
| isDoComprehensionContext sc = False
| otherwise = prec > topPrec
+ go (PopSrcSpan{}) = prec > topPrec
go (ExplicitList{}) = False
go (RecordUpd{}) = False
go (ExprWithTySig{}) = prec >= sigPrec
@@ -1107,9 +1114,9 @@ data HsExpansion orig expanded
-- | Just print the original expression (the @a@) with the expanded version (the @b@)
instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where
ppr (HsExpanded orig expanded)
- -- = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)])
- -- (ppr orig)
- = braces (ppr orig) $$ braces (text "Expansion:" <+> ppr expanded)
+ = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)])
+ (ppr orig)
+ -- = braces (ppr orig) $$ braces (text "Expansion:" <+> ppr expanded)
{-
=====================================
compiler/GHC/Hs/Syn/Type.hs
=====================================
@@ -114,6 +114,7 @@ hsExprType (HsIf _ _ t _) = lhsExprType t
hsExprType (HsMultiIf ty _) = ty
hsExprType (HsLet _ _ _ _ body) = lhsExprType body
hsExprType (HsDo ty _ _) = ty
+hsExprType (PopSrcSpan expr) = pprPanic "hsExprType" (text "impossible happened PopSrcSpan" <+> ppr expr)
hsExprType (ExplicitList ty _) = mkListTy ty
hsExprType (RecordCon con_expr _ _) = hsExprType con_expr
hsExprType (RecordUpd v _ _) = dataConCantHappen v
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -29,6 +29,7 @@ import GHC.HsToCore.Utils
import GHC.HsToCore.Arrows
import GHC.HsToCore.Monad
import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs )
+import GHC.HsToCore.Pmc.Utils
import GHC.HsToCore.Errors.Types
import GHC.Types.SourceText
import GHC.Types.Name
@@ -258,6 +259,8 @@ dsExpr (HsOverLit _ lit)
= do { warnAboutOverflowedOverLit lit
; dsOverLit lit }
+dsExpr e@(PopSrcSpan {}) = pprPanic "dsExpr" (ppr e)
+
dsExpr e@(XExpr ext_expr_tc)
= case ext_expr_tc of
ExpansionExpr (HsExpanded _ b) -> dsExpr b
@@ -857,15 +860,22 @@ warnUnusedBindValue :: LHsExpr GhcTc -> LHsExpr GhcTc -> Type -> DsM ()
warnUnusedBindValue fun arg arg_ty
| Just (SrcSpanAnn _ l, f) <- fish_var fun
, is_gen_then f
- , isNoSrcSpan l
- = warnDiscardedDoBindings arg arg_ty
+ -- , isNoSrcSpan l
+ = do tracePm "warnUnusedBindValue" (vcat [ text "fun" <+> ppr fun
+ , text "arg" <+> ppr arg
+ , text "arg_ty" <+> ppr arg_ty
+ , text "f" <+> ppr f <+> ppr (is_gen_then f)
+ , text "l" <+> ppr (isNoSrcSpan l)])
+ warnDiscardedDoBindings arg arg_ty
where
-- retrieve the location info and the head of the application
fish_var :: LHsExpr GhcTc -> Maybe (SrcSpanAnnA , LIdP GhcTc)
fish_var (L l (HsVar _ id)) = return (l, id)
+ fish_var (L _ (PopSrcSpan e)) = pprPanic "warnUnusedBindValue" (ppr e)
fish_var (L _ (HsAppType _ e _ _)) = fish_var e
fish_var (L l (XExpr (WrapExpr (HsWrap _ e)))) = do (l, e') <- fish_var (L l e)
return (l, e')
+ fish_var (L l (XExpr (ExpansionExpr (HsExpanded _ e)))) = fish_var (L l e)
fish_var _ = Nothing
-- is this id a compiler generated (>>) with expanded do
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -1663,7 +1663,7 @@ repE e@(HsPragE _ (HsPragSCC {}) _) = notHandled (ThCostCentres e)
repE e@(HsTypedBracket{}) = notHandled (ThExpressionForm e)
repE e@(HsUntypedBracket{}) = notHandled (ThExpressionForm e)
repE e@(HsProc{}) = notHandled (ThExpressionForm e)
-
+repE e@(PopSrcSpan{}) = notHandled (ThExpressionForm e)
{- Note [Quotation and rebindable syntax]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1234,6 +1234,7 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
]
HsGetField {} -> []
HsProjection {} -> []
+ PopSrcSpan {} -> []
XExpr x
| HieTc <- hiePass @p
-> case x of
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -560,6 +560,8 @@ rnExpr (ArithSeq _ _ seq)
else
return (ArithSeq noExtField Nothing new_seq, fvs) }
+rnExpr (PopSrcSpan _) = panic "impossible happened rnExpr PopSrcSpan"
+
{-
************************************************************************
* *
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -408,9 +408,33 @@ tcExpr (HsMultiIf _ alts) res_ty
; return (HsMultiIf res_ty alts') }
where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }
+tcExpr (HsDo _ doFlav@(DoExpr{}) (L loc stmts)) res_ty
+ = do { expand_expr <- expandDoStmts doFlav stmts
+ ; let expand_do_expr = mkExpandedExpr (HsDo noExtField doFlav (L loc stmts))
+ (unLoc expand_expr)
+ -- Do expansion on the fly
+ ; traceTc "tcDoStmts do" (vcat [ text "original:" <+> ppr expand_do_expr
+ , text "expanded:" <+> ppr expand_expr
+ ])
+ ; tcExpr expand_do_expr res_ty
+ }
+
+tcExpr (HsDo _ doFlav@(MDoExpr{}) (L loc stmts)) res_ty
+ = do { expand_expr <- expandDoStmts doFlav stmts
+ ; let expand_do_expr = mkExpandedExpr (HsDo noExtField doFlav (L loc stmts))
+ (unLoc expand_expr)
+ -- Do expansion on the fly
+ ; traceTc "tcDoStmts do" (vcat [ text "original:" <+> ppr expand_do_expr
+ , text "expanded:" <+> ppr expand_expr
+ ])
+ ; tcExpr expand_do_expr res_ty
+ }
+
tcExpr (HsDo _ do_or_lc stmts) res_ty
= tcDoStmts do_or_lc stmts res_ty
+tcExpr (PopSrcSpan (L _ expr)) res_ty = popErrCtxt $ tcExpr expr res_ty
+
tcExpr (HsProc x pat cmd) res_ty
= do { (pat', cmd', coi) <- tcProc pat cmd res_ty
; return $ mkHsWrapCo coi (HsProc x pat' cmd') }
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -32,6 +32,7 @@ module GHC.Tc.Gen.Match
, tcDoStmt
, tcGuardStmt
, checkArgCounts
+ , expandDoStmts
)
where
@@ -319,32 +320,34 @@ tcDoStmts ListComp (L l stmts) res_ty
(mkCheckExpType elt_ty)
; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) }
-tcDoStmts doExpr@(DoExpr _) (L l stmts) res_ty
- = do { -- stmts' <- tcStmts (HsDoStmt doExpr) tcDoStmt stmts res_ty
+tcDoStmts (DoExpr _) ss _
+ = pprPanic "tcDoStmts DoExpr" (ppr ss) -- do {
+ -- stmts' <- tcStmts (HsDoStmt doExpr) tcDoStmt stmts res_ty
-- ; res_ty <- readExpType res_ty
-- ; return (HsDo res_ty doExpr (L l stmts'))
- expand_expr <- expand_do_stmts doExpr stmts
- ; let expand_do_expr = mkExpandedExpr (HsDo noExtField doExpr (L l stmts))
- (unLoc expand_expr)
- -- Do expansion on the fly
- ; traceTc "tcDoStmts do" (vcat [ text "original:" <+> ppr expand_do_expr
- , text "expanded:" <+> ppr expand_expr
- ])
- ; tcExpr expand_do_expr res_ty
- }
-
-tcDoStmts mDoExpr@(MDoExpr _) (L l stmts) res_ty
- = do { -- stmts' <- tcStmts (HsDoStmt mDoExpr) tcDoStmt stmts res_ty
- -- ; res_ty <- readExpType res_ty
+ -- expand_expr <- expand_do_stmts doExpr stmts
+ -- ; let expand_do_expr = mkExpandedExpr (HsDo noExtField doExpr (L l stmts))
+ -- (unLoc expand_expr)
+ -- -- Do expansion on the fly
+ -- ; traceTc "tcDoStmts do" (vcat [ text "original:" <+> ppr expand_do_expr
+ -- , text "expanded:" <+> ppr expand_expr
+ -- ])
+ -- ; tcExpr expand_do_expr res_ty
+ -- }
+
+tcDoStmts (MDoExpr _) ss _
+ = pprPanic "tcDoStmts MDoExpr" (ppr ss)
+ --do { -- stmts' <- tcStmts (HsDoStmt mDoExpr) tcDoStmt stmts res_ty
+ -- ; res_ty <- readExpType res_ty
-- ; return (HsDo res_ty mDoExpr (L l stmts'))
- expand_expr <- expand_do_stmts mDoExpr stmts
- ; let expand_do_expr = mkExpandedExpr (HsDo noExtField mDoExpr (L l stmts))
- (unLoc expand_expr)
- -- Do expansion on the fly
- ; traceTc "tcDoStmts mdo" (text "tcExpr:" <+> ppr expand_do_expr)
- ; tcExpr expand_do_expr res_ty
+ -- expand_expr <- expand_do_stmts mDoExpr stmts
+ -- ; let expand_do_expr = mkExpandedExpr (HsDo noExtField mDoExpr (L l stmts))
+ -- (unLoc expand_expr)
+ -- -- Do expansion on the fly
+ -- ; traceTc "tcDoStmts mdo" (text "tcExpr:" <+> ppr expand_do_expr)
+ -- ; tcExpr expand_do_expr res_ty
- }
+ -- }
tcDoStmts MonadComp (L l stmts) res_ty
= do { stmts' <- tcStmts (HsDoStmt MonadComp) tcMcStmt stmts res_ty
@@ -1201,6 +1204,9 @@ checkArgCounts matchContext (MG { mg_alts = L _ (match1:matches) })
* *
************************************************************************
-}
+expandDoStmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn)
+expandDoStmts = expand_do_stmts
+
-- | Expand the Do statments so that it works fine with Quicklook
-- See Note[Rebindable Do and Expanding Statements]
-- ANI Questions: 1. What should be the location information in the expanded expression?
@@ -1230,7 +1236,9 @@ expand_do_stmts do_or_lc ((L _ (BindStmt xbsrn pat e)): lstmts)
| SyntaxExprRn bind_op <- xbsrn_bindOp xbsrn
, fail_op <- xbsrn_failOp xbsrn =
-- the pattern binding x can fail
--- stmts ~~> stmt' let f pat = stmts'; f _ = fail ".."
+-- instead of making an internal name, the fail block is just an anonymous match block
+-- stmts ~~> stmt' let / = stmts';
+-- _ = fail "..";
-- -------------------------------------------------------
-- pat <- e ; stmts ~~> (>>=) e f
do expand_stmts <- expand_do_stmts do_or_lc lstmts
@@ -1248,7 +1256,7 @@ expand_do_stmts do_or_lc ((L _ (BindStmt xbsrn pat e)): lstmts)
expand_stmts <- expand_do_stmts do_or_lc lstmts
return $ mkHsApps (genLHsVar bindMName) -- (Prelude.>>=)
[ e
- , mkHsLam [pat] expand_stmts -- (\ x -> stmts')
+ , mkHsLam [pat] (noLocA $ PopSrcSpan expand_stmts) -- (\ x -> stmts')
]
expand_do_stmts do_or_lc (L _ (LetStmt _ bnds) : lstmts) =
@@ -1265,9 +1273,9 @@ expand_do_stmts do_or_lc ((L _ (BodyStmt _ e (SyntaxExprRn f) _)) : lstmts) =
-- ----------------------------------------------
-- e ; stmts ~~> (>>) e stmts'
do expand_stmts <- expand_do_stmts do_or_lc lstmts
- return $ mkHsApps (wrapGenSpan f) -- (>>)
- [ e -- e
- , expand_stmts ] -- stmts'
+ return $ noLocA (PopSrcSpan (mkHsApps (wrapGenSpan f) -- (>>)
+ [ e -- e
+ , expand_stmts ])) -- stmts'
expand_do_stmts do_or_lc
((L _ (RecStmt { recS_stmts = rec_stmts
@@ -1288,11 +1296,11 @@ expand_do_stmts do_or_lc
-- ; return (local_only_ids ++ later_ids) } ))
-- (\ [ local_only_ids ++ later_ids ] -> stmts')
do expand_stmts <- expand_do_stmts do_or_lc lstmts
- return $ (mkHsApps (genLHsVar bindMName) -- (Prelude.>>=)
- [ (wrapGenSpan mfix_fun) `mkHsApp` mfix_expr -- (mfix (do block))
- , mkHsLam [ mkBigLHsVarPatTup all_ids ] -- (\ x ->
- expand_stmts -- stmts')
- ])
+ return $ mkHsApps (genLHsVar bindMName) -- (Prelude.>>=)
+ [ (wrapGenSpan mfix_fun) `mkHsApp` mfix_expr -- (mfix (do block))
+ , mkHsLam [ mkBigLHsVarPatTup all_ids ] -- (\ x ->
+ (noLocA $ PopSrcSpan expand_stmts) -- stmts')
+ ]
where
local_only_ids = local_ids \\ later_ids -- get unique local rec ids;
--local rec ids and later ids can overlap
@@ -1376,9 +1384,12 @@ mk_failable_lexpr_tcm pat lexpr fail_op =
do { ((tc_pat, _), _) <- tcInferPat (FRRBindStmt DoNotation)
PatBindRhs pat $ return id -- whatever
; dflags <- getDynFlags
+ ; traceTc "mk_fail_lexpr_tcm" (vcat [ppr tc_pat
+ , ppr $ isIrrefutableHsPat dflags tc_pat
+ , ppr $ isPatSynCon (unLoc tc_pat)])
; if isIrrefutableHsPat dflags tc_pat -- don't decorate with fail statement if the pattern is irrefutable
|| (isPatSynCon (unLoc tc_pat)) -- pattern syns always get a fail block while desugaring so skip
- then return $ mkHsLam [pat] lexpr
+ then return $ mkHsLam [pat] (noLocA (PopSrcSpan lexpr))
else mk_fail_lexpr pat lexpr fail_op
}
where isPatSynCon (ConPat {pat_con = L _ (PatSynCon _)}) = True
@@ -1391,7 +1402,7 @@ 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 -- \
- (noLocA [ mkHsCaseAlt pat lexpr -- pat -> expr
+ (noLocA [ mkHsCaseAlt pat (noLocA $ PopSrcSpan lexpr) -- pat -> expr
, mkHsCaseAlt nlWildPatName -- _ -> fail "fail pattern"
(noLocA $ genHsApp fail_op
(mk_fail_msg_expr dflags (DoExpr Nothing) pat))
=====================================
compiler/GHC/Tc/Utils/Zonk.hs
=====================================
@@ -846,6 +846,8 @@ zonkExpr env (HsDo ty do_or_lc (L l stmts))
new_ty <- zonkTcTypeToTypeX env ty
return (HsDo new_ty do_or_lc (L l new_stmts))
+zonkExpr env (PopSrcSpan (L _ exp)) = zonkExpr env exp
+
zonkExpr env (ExplicitList ty exprs)
= do new_ty <- zonkTcTypeToTypeX env ty
new_exprs <- zonkLExprs env exprs
=====================================
compiler/Language/Haskell/Syntax/Expr.hs
=====================================
@@ -584,6 +584,11 @@ data HsExpr p
-- general idea, and Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr
-- for an example of how we use it.
+ | PopSrcSpan (LHsExpr p)
+ -- Placeholder for identifying generated source locations in GhcRn phase
+ -- Should not presist post typechecking
+ -- Note [Desugaring Do with HsExpansion] TODO
+
-- ---------------------------------------------------------------------
data DotFieldOcc p
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/370f8052b58945d7d7c4917c89728fe6bab92660
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/370f8052b58945d7d7c4917c89728fe6bab92660
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/20230501/f5c73af1/attachment-0001.html>
More information about the ghc-commits
mailing list