[Git][ghc/ghc][wip/expansions-appdo] simplify splitHsApps
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Tue Jul 9 01:00:36 UTC 2024
Apoorv Ingle pushed to branch wip/expansions-appdo at Glasgow Haskell Compiler / GHC
Commits:
3e71d399 by Apoorv Ingle at 2024-07-08T19:46:43-05:00
simplify splitHsApps
- - - - -
6 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Instances.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
=====================================
@@ -473,15 +473,13 @@ type instance XXExpr GhcTc = XXExprGhcTc
* *
********************************************************************* -}
--- | Hint to the typechecker how to typecheck the expanded expression
-data TCFunInfo = TcApp -- use tcApp to typecheck
- | TcExpr -- use tcExpr to typecheck
-
-- | The different source constructs that we use to instantiate the "original" field
--- in an `XXExprGhcRn original expansion`
+-- in an `XXExprGhcRn original expansion` (See below)
data HsThingRn = OrigExpr (HsExpr GhcRn)
| OrigStmt (ExprLStmt GhcRn) HsDoFlavour -- ^ which kind of do-block did this statement come from
- | OrigPat (LPat GhcRn) HsDoFlavour (Maybe (ExprLStmt GhcRn))
+ | OrigPat (LPat GhcRn)
+ HsDoFlavour -- ^ which kind of do-block did this statement come from
+ (Maybe (ExprLStmt GhcRn)) -- ^ the statement binding this pattern
isHsThingRnExpr, isHsThingRnStmt, isHsThingRnPat :: HsThingRn -> Bool
isHsThingRnExpr (OrigExpr{}) = True
@@ -494,11 +492,11 @@ isHsThingRnPat (OrigPat{}) = True
isHsThingRnPat _ = False
data XXExprGhcRn
- = ExpandedThingRn { xrn_orig :: HsThingRn -- The original source thing
+ = ExpandedThingRn { xrn_orig :: HsThingRn -- The original source thing to be used for error messages
, xrn_expanded :: HsExpr GhcRn -- The compiler generated expanded thing
- , xrn_TCFunInfo :: TCFunInfo } -- A Hint to the type checker of how to proceed
- -- TcApp <=> use GHC.Tc.Gen.Expr.tcApp
- -- TcExpr <=> use GHC.Tc.Gen.Expr.tcExpr
+ , xrn_doTcApp :: Bool } -- A Hint to the type checker of how to proceed
+ -- True <=> use GHC.Tc.Gen.Expr.tcApp
+ -- False <=> use GHC.Tc.Gen.Expr.tcExpr
| PopErrCtxt -- A hint for typechecker to pop
{-# UNPACK #-} !(LHsExpr GhcRn) -- the top of the error context stack
@@ -524,30 +522,30 @@ mkExpandedExpr
-> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
mkExpandedExpr oExpr eExpr = XExpr (ExpandedThingRn { xrn_orig = OrigExpr oExpr
, xrn_expanded = eExpr
- , xrn_TCFunInfo = TcExpr })
+ , xrn_doTcApp = False })
-- | Build an expression using the extension constructor `XExpr`,
-- and the two components of the expansion: original do stmt and
-- expanded expression
mkExpandedStmt
:: ExprLStmt GhcRn -- ^ source statement
- -> HsDoFlavour
- -> TCFunInfo
+ -> HsDoFlavour -- ^ source statement do flavour
+ -> Bool -- ^ should this be type checked using tcApp?
-> HsExpr GhcRn -- ^ expanded expression
-> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
-mkExpandedStmt oStmt flav tc_fun eExpr = XExpr (ExpandedThingRn { xrn_orig = OrigStmt oStmt flav
+mkExpandedStmt oStmt flav doTcApp eExpr = XExpr (ExpandedThingRn { xrn_orig = OrigStmt oStmt flav
, xrn_expanded = eExpr
- , xrn_TCFunInfo = tc_fun})
+ , xrn_doTcApp = doTcApp})
mkExpandedPatRn
:: LPat GhcRn -- ^ source pattern
- -> HsDoFlavour
+ -> HsDoFlavour -- ^ source statement do flavour
-> Maybe (ExprLStmt GhcRn) -- ^ pattern statement origin
-> HsExpr GhcRn -- ^ expanded expression
-> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
mkExpandedPatRn oPat flav mb_stmt eExpr = XExpr (ExpandedThingRn { xrn_orig = OrigPat oPat flav mb_stmt
, xrn_expanded = eExpr
- , xrn_TCFunInfo = TcExpr})
+ , xrn_doTcApp = False})
-- | Build an expression using the extension constructor `XExpr`,
-- and the two components of the expansion: original do stmt and
@@ -557,14 +555,14 @@ mkExpandedStmtAt
-> SrcSpanAnnA -- ^ Location for the expansion expression
-> ExprLStmt GhcRn -- ^ source statement
-> HsDoFlavour -- ^ the flavour of the statement
- -> TCFunInfo -- ^ should type check with tcApp or tcExpr
+ -> Bool -- ^ should type check with tcApp?
-> HsExpr GhcRn -- ^ expanded expression
-> LHsExpr GhcRn -- ^ suitably wrapped located 'XXExprGhcRn'
-mkExpandedStmtAt addPop loc oStmt flav tcFun eExpr
+mkExpandedStmtAt addPop loc oStmt flav doTcApp eExpr
| addPop
- = mkPopErrCtxtExprAt loc (L loc $ mkExpandedStmt oStmt flav tcFun eExpr)
+ = mkPopErrCtxtExprAt loc (L loc $ mkExpandedStmt oStmt flav doTcApp eExpr)
| otherwise
- = L loc $ mkExpandedStmt oStmt flav tcFun eExpr
+ = L loc $ mkExpandedStmt oStmt flav doTcApp eExpr
data XXExprGhcTc
= WrapExpr -- Type and evidence application and abstractions
@@ -858,7 +856,7 @@ instance Outputable HsThingRn where
= case thing of
OrigExpr x -> ppr_builder "<OrigExpr>:" x
OrigStmt x _ -> ppr_builder "<OrigStmt>:" x
- OrigPat x _ _ -> ppr_builder "<OrigPat>:" x
+ OrigPat x _ mb_stmt -> ifPprDebug (braces (text "<OrigPat>" <+> parens (ppr x) <+> parens (ppr mb_stmt))) (ppr x)
where ppr_builder prefix x = ifPprDebug (braces (text prefix <+> parens (ppr x))) (ppr x)
instance Outputable XXExprGhcRn where
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -569,7 +569,6 @@ deriving instance Eq (IE GhcTc)
-- ---------------------------------------------------------------------
deriving instance Data HsThingRn
-deriving instance Data TCFunInfo
deriving instance Data XXExprGhcRn
deriving instance Data XXExprGhcTc
deriving instance Data XXPatGhcTc
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -898,9 +898,6 @@ addArgCtxt :: AppCtxt -> LHsExpr GhcRn
addArgCtxt ctxt (L arg_loc arg) thing_inside
= do { in_generated_code <- inGeneratedCode
; case ctxt of
- VACall{}
- | XExpr (PopErrCtxt{}) <- arg
- -> thing_inside
VACall{}
| XExpr (ExpandedThingRn o _ _) <- arg
, isHsThingRnStmt o || isHsThingRnPat o
=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -80,7 +80,7 @@ expand_do_stmts addPop flav [stmt@(L loc (LastStmt _ (L body_loc body) _ ret_exp
-- 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 addPop loc stmt flav TcExpr body
+ = return $ mkExpandedStmtAt addPop loc stmt flav False body
| SyntaxExprRn ret <- ret_expr
--
@@ -88,7 +88,7 @@ expand_do_stmts addPop flav [stmt@(L loc (LastStmt _ (L body_loc body) _ ret_exp
-- return e ~~> return e
-- to make T18324 work
= do let expansion = genHsApp ret (L body_loc body)
- return $ mkExpandedStmtAt addPop loc stmt flav TcExpr expansion
+ return $ mkExpandedStmtAt addPop loc stmt flav False expansion
expand_do_stmts addPop doFlavour (stmt@(L loc (LetStmt _ bs)) : lstmts) =
-- See Note [Expanding HsDo with XXExprGhcRn] Equation (3) below
@@ -97,7 +97,7 @@ expand_do_stmts addPop doFlavour (stmt@(L loc (LetStmt _ bs)) : lstmts) =
-- let x = e ; stmts ~~> let x = e in stmts'
do expand_stmts <- expand_do_stmts True doFlavour lstmts
let expansion = genHsLet bs expand_stmts
- return $ mkExpandedStmtAt addPop loc stmt doFlavour TcExpr expansion
+ return $ mkExpandedStmtAt addPop loc stmt doFlavour False expansion
expand_do_stmts addPop doFlavour (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
| SyntaxExprRn bind_op <- xbsrn_bindOp xbsrn
@@ -113,7 +113,7 @@ expand_do_stmts addPop doFlavour (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
let expansion = genHsExpApps bind_op -- (>>=)
[ e
, failable_expr ]
- return $ mkExpandedStmtAt addPop loc stmt doFlavour TcApp expansion
+ return $ mkExpandedStmtAt addPop loc stmt doFlavour True expansion
| otherwise
= pprPanic "expand_do_stmts: The impossible happened, missing bind operator from renamer" (text "stmt" <+> ppr stmt)
@@ -128,7 +128,7 @@ expand_do_stmts addPop doFlavour (stmt@(L loc (BodyStmt _ e (SyntaxExprRn then_o
let expansion = genHsExpApps then_op -- (>>)
[ e
, expand_stmts_expr ]
- return $ mkExpandedStmtAt addPop loc stmt doFlavour TcApp expansion
+ return $ mkExpandedStmtAt addPop loc stmt doFlavour True expansion
expand_do_stmts _ doFlavour
((L loc (RecStmt { recS_stmts = L stmts_loc rec_stmts
@@ -196,7 +196,7 @@ expand_do_stmts addPop doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join)
-- add blocks for failable patterns
; body_with_fails <- foldrM match_args xexpr (zip pats_can_fail rhss)
- -- builds (body <$> e1 <*> e2 ...)
+ -- builds (((body <$> e1) <*> e2) ...)
; let expand_ado_expr = foldl mk_apps body_with_fails (zip (map fst args) rhss)
-- wrap the expanded expression with a `join` if needed
@@ -219,7 +219,7 @@ expand_do_stmts addPop doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join)
, arg_expr = (L rhs_loc rhs)
, is_body_stmt = is_body_stmt
}) =
- do let xx_expr = mkExpandedStmtAt addPop rhs_loc stmt doFlavour TcExpr rhs
+ do let xx_expr = mkExpandedStmtAt addPop rhs_loc stmt doFlavour False rhs
traceTc "do_arg" (text "OneArg" <+> vcat [ppr pat, ppr xx_expr])
return ((pat, mb_fail_op)
, xx_expr)
@@ -269,7 +269,7 @@ mk_failable_expr doFlav mb_stmt lpat@(L loc pat) expr fail_op =
(WildPat{}) -> return $ genHsLamDoExp doFlav [L noSrcSpanA pat] expr
_ -> return $ case mb_stmt of
Nothing -> genHsLamDoExp doFlav [lpat] expr
- Just s -> wrapGenSpan (mkExpandedStmt s doFlav TcExpr
+ Just s -> wrapGenSpan (mkExpandedStmt s doFlav False
(unLoc $ (genHsLamDoExp doFlav [lpat]
$ wrapGenSpan (mkPopErrCtxtExpr expr))))
else L loc <$> mk_fail_block doFlav mb_stmt lpat expr fail_op
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -714,7 +714,7 @@ tcXExpr (PopErrCtxt (L loc e)) res_ty
setSrcSpanA loc $
tcExpr e res_ty
-tcXExpr xe@(ExpandedThingRn o e' tc_info) res_ty
+tcXExpr xe@(ExpandedThingRn o e' doTcApp) res_ty
| OrigStmt ls@(L loc s at LetStmt{}) flav <- o
, HsLet x binds e <- e'
= do { (binds', wrapper, e') <- setSrcSpanA loc $
@@ -726,16 +726,21 @@ tcXExpr xe@(ExpandedThingRn o e' tc_info) res_ty
}
| OrigStmt ls@(L loc s) flav <- o
- , TcExpr <- tc_info
+ , not doTcApp
= setSrcSpanA loc $
addStmtCtxt s flav $
mkExpandedStmtTc ls flav <$> tcExpr e' res_ty
| OrigStmt ls@(L loc _) flav <- o
- , TcApp <- tc_info
+ , doTcApp
= setSrcSpanA loc $
mkExpandedStmtTc ls flav <$> tcApp (XExpr xe) res_ty
+ | OrigPat (L loc _) flav (Just s) <- o -- testcase T16628
+ = setSrcSpanA loc $
+ addStmtCtxt (unLoc s) flav $
+ tcApp (XExpr xe) res_ty
+
tcXExpr xe res_ty = tcApp (XExpr xe) res_ty
{-
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -300,8 +300,8 @@ splitHsApps e = go e (top_ctxt 0 e) []
top_ctxt n (HsPragE _ _ fun) = top_lctxt n fun
top_ctxt n (HsAppType _ fun _) = top_lctxt (n+1) fun
top_ctxt n (HsApp _ fun _) = top_lctxt (n+1) fun
- top_ctxt n (XExpr (ExpandedThingRn o _ _))
- | OrigExpr fun <- o = VACall fun n noSrcSpan
+ top_ctxt n (XExpr (ExpandedThingRn (OrigExpr fun) _ _))
+ = VACall fun n noSrcSpan
top_ctxt n other_fun = VACall other_fun n noSrcSpan
top_lctxt n (L _ fun) = top_ctxt n fun
@@ -326,24 +326,6 @@ splitHsApps e = go e (top_ctxt 0 e) []
-- See Note [Looking through ExpandedThingRn]
go (XExpr (ExpandedThingRn o e _)) ctxt args
- | isHsThingRnExpr o
- = go e (VAExpansion o (appCtxtLoc ctxt) (appCtxtLoc ctxt))
- (EWrap (EExpand o) : args)
-
- | OrigStmt (L _ stmt) _ <- o -- so that we set `(>>)` as generated
- , BodyStmt{} <- stmt -- and get the right unused bind warnings
- = go e (VAExpansion o generatedSrcSpan generatedSrcSpan)
- -- See Part 3. in Note [Expanding HsDo with XXExprGhcRn]
- (EWrap (EExpand o) : args) -- in `GHC.Tc.Gen.Do`
-
-
- | OrigPat (L loc _) _ _ <- o -- so that we set the compiler generated fail context
- = go e (VAExpansion o (locA loc) (locA loc)) -- to be originating from a failable pattern
- -- See Part 1. Wrinkle 2. of
- (EWrap (EExpand o) : args) -- Note [Expanding HsDo with XXExprGhcRn]
- -- in `GHC.Tc.Gen.Do`
-
- | otherwise
= go e (VAExpansion o (appCtxtLoc ctxt) (appCtxtLoc ctxt))
(EWrap (EExpand o) : args)
@@ -1285,6 +1267,7 @@ addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt e thing_inside
= case e of
HsUnboundVar {} -> thing_inside
+ XExpr (PopErrCtxt (L l e)) -> popErrCtxt $ setSrcSpanA l $ addExprCtxt e $ thing_inside
XExpr (ExpandedThingRn (OrigStmt stmt flav) _ _) -> addStmtCtxt (unLoc stmt) flav thing_inside
_ -> addErrCtxt (exprCtxt e) thing_inside
-- The HsUnboundVar special case addresses situations like
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3e71d39916efb633c4a5e5822ce731e8784d3789
--
This project does not include diff previews in email notifications.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3e71d39916efb633c4a5e5822ce731e8784d3789
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/20240708/cd32bc99/attachment-0001.html>
More information about the ghc-commits
mailing list