[Git][ghc/ghc][wip/expansions-appdo] guide the typechecker by providing info in the expanded syntax tree (TCFunInfo)
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Mon May 27 15:15:28 UTC 2024
Apoorv Ingle pushed to branch wip/expansions-appdo at Glasgow Haskell Compiler / GHC
Commits:
8e7fd9c0 by Apoorv Ingle at 2024-05-27T10:15:04-05:00
guide the typechecker by providing info in the expanded syntax tree (TCFunInfo)
- - - - -
8 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/HsToCore/Quote.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
- compiler/GHC/Tc/Types/Origin.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -473,6 +473,8 @@ type instance XXExpr GhcTc = XXExprGhcTc
* *
********************************************************************* -}
+data TCFunInfo = TcApp | TcExpr
+
-- | The different source constructs that we use to instantiate the "original" field
-- in an `XXExprGhcRn original expansion`
data HsThingRn = OrigExpr (HsExpr GhcRn)
@@ -491,7 +493,8 @@ isHsThingRnPat _ = False
data XXExprGhcRn
= ExpandedThingRn { xrn_orig :: HsThingRn -- The original source thing
- , xrn_expanded :: HsExpr GhcRn } -- The compiler generated expanded thing
+ , xrn_expanded :: HsExpr GhcRn -- The compiler generated expanded thing
+ , xrn_TCFunInfo :: TCFunInfo } -- A Hint to the type checker of how to proceed
| PopErrCtxt -- A hint for typechecker to pop
{-# UNPACK #-} !(LHsExpr GhcRn) -- the top of the error context stack
@@ -515,7 +518,7 @@ mkExpandedExpr
:: HsExpr GhcRn -- ^ source expression
-> HsExpr GhcRn -- ^ expanded expression
-> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
-mkExpandedExpr oExpr eExpr = XExpr (ExpandedThingRn (OrigExpr oExpr) eExpr)
+mkExpandedExpr oExpr eExpr = XExpr (ExpandedThingRn (OrigExpr oExpr) eExpr TcExpr)
-- | Build an expression using the extension constructor `XExpr`,
-- and the two components of the expansion: original do stmt and
@@ -523,16 +526,17 @@ mkExpandedExpr oExpr eExpr = XExpr (ExpandedThingRn (OrigExpr oExpr) eExpr)
mkExpandedStmt
:: ExprLStmt GhcRn -- ^ source statement
-> HsDoFlavour
+ -> TCFunInfo
-> HsExpr GhcRn -- ^ expanded expression
-> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
-mkExpandedStmt oStmt flav eExpr = XExpr (ExpandedThingRn (OrigStmt oStmt flav) eExpr)
+mkExpandedStmt oStmt flav tc_fun eExpr = XExpr (ExpandedThingRn (OrigStmt oStmt flav) eExpr tc_fun)
mkExpandedPatRn
:: LPat GhcRn -- ^ source pattern
-> Maybe (HsDoFlavour, ExprLStmt GhcRn) -- ^ pattern statement origin
-> HsExpr GhcRn -- ^ expanded expression
-> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
-mkExpandedPatRn oPat stmt eExpr = XExpr (ExpandedThingRn (OrigPat oPat stmt) eExpr)
+mkExpandedPatRn oPat stmt eExpr = XExpr (ExpandedThingRn (OrigPat oPat stmt) eExpr TcExpr)
-- | Build an expression using the extension constructor `XExpr`,
-- and the two components of the expansion: original do stmt and
@@ -541,18 +545,20 @@ mkExpandedStmtAt
:: SrcSpanAnnA -- ^ Location for the expansion expression
-> ExprLStmt GhcRn -- ^ source statement
-> HsDoFlavour
+ -> TCFunInfo
-> HsExpr GhcRn -- ^ expanded expression
-> LHsExpr GhcRn -- ^ suitably wrapped located 'XXExprGhcRn'
-mkExpandedStmtAt loc oStmt flav eExpr = L loc $ mkExpandedStmt oStmt flav eExpr
+mkExpandedStmtAt loc oStmt flav tcFun eExpr = L loc $ mkExpandedStmt oStmt flav tcFun eExpr
-- | Wrap the expanded version of the expression with a pop.
mkExpandedStmtPopAt
:: SrcSpanAnnA -- ^ Location for the expansion statement
-> ExprLStmt GhcRn -- ^ source statement
-> HsDoFlavour
+ -> TCFunInfo
-> HsExpr GhcRn -- ^ expanded expression
-> LHsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
-mkExpandedStmtPopAt loc oStmt flav eExpr = mkPopErrCtxtExprAt loc $ mkExpandedStmtAt loc oStmt flav eExpr
+mkExpandedStmtPopAt loc oStmt flav tc_fun eExpr = mkPopErrCtxtExprAt loc $ mkExpandedStmtAt loc oStmt flav tc_fun eExpr
data XXExprGhcTc
@@ -846,8 +852,8 @@ instance Outputable HsThingRn where
where ppr_builder prefix x = ifPprDebug (braces (text prefix <+> parens (ppr x))) (ppr x)
instance Outputable XXExprGhcRn where
- ppr (ExpandedThingRn o e) = ifPprDebug (braces $ vcat [ppr o, text ";;" , ppr e]) (ppr o)
- ppr (PopErrCtxt e) = ifPprDebug (braces (text "<PopErrCtxt>" <+> ppr e)) (ppr e)
+ ppr (ExpandedThingRn o e _) = ifPprDebug (braces $ vcat [ppr o, text ";;" , ppr e]) (ppr o)
+ ppr (PopErrCtxt e) = ifPprDebug (braces (text "<PopErrCtxt>" <+> ppr e)) (ppr e)
instance Outputable XXExprGhcTc where
ppr (WrapExpr (HsWrap co_fn e))
@@ -887,7 +893,7 @@ ppr_infix_expr (XExpr x) = case ghcPass @p of
ppr_infix_expr _ = Nothing
ppr_infix_expr_rn :: XXExprGhcRn -> Maybe SDoc
-ppr_infix_expr_rn (ExpandedThingRn thing _) = ppr_infix_hs_expansion thing
+ppr_infix_expr_rn (ExpandedThingRn thing _ _) = ppr_infix_hs_expansion thing
ppr_infix_expr_rn (PopErrCtxt (L _ a)) = ppr_infix_expr a
ppr_infix_expr_tc :: XXExprGhcTc -> Maybe SDoc
@@ -998,7 +1004,7 @@ hsExprNeedsParens prec = go
go_x_tc (HsBinTick _ _ (L _ e)) = hsExprNeedsParens prec e
go_x_rn :: XXExprGhcRn -> Bool
- go_x_rn (ExpandedThingRn thing _) = hsExpandedNeedsParens thing
+ go_x_rn (ExpandedThingRn thing _ _) = hsExpandedNeedsParens thing
go_x_rn (PopErrCtxt (L _ a)) = hsExprNeedsParens prec a
hsExpandedNeedsParens :: HsThingRn -> Bool
@@ -1050,7 +1056,7 @@ isAtomicHsExpr (XExpr x)
go_x_tc (HsBinTick {}) = False
go_x_rn :: XXExprGhcRn -> Bool
- go_x_rn (ExpandedThingRn thing _) = isAtomicExpandedThingRn thing
+ go_x_rn (ExpandedThingRn thing _ _) = isAtomicExpandedThingRn thing
go_x_rn (PopErrCtxt (L _ a)) = isAtomicHsExpr a
isAtomicExpandedThingRn :: HsThingRn -> Bool
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -569,6 +569,7 @@ 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/HsToCore/Quote.hs
=====================================
@@ -1685,7 +1685,7 @@ repE (HsProjection _ xs) = repProjection (fmap (field_label . unLoc . dfoLabel .
repE (HsEmbTy _ t) = do
t1 <- repLTy (hswc_body t)
rep2 typeEName [unC t1]
-repE e@(XExpr (ExpandedThingRn o x))
+repE e@(XExpr (ExpandedThingRn o x _))
| OrigExpr e <- o
= do { rebindable_on <- lift $ xoptM LangExt.RebindableSyntax
; if rebindable_on -- See Note [Quotation and rebindable syntax]
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -799,7 +799,7 @@ addArgCtxt ctxt (L arg_loc arg) thing_inside
| XExpr (PopErrCtxt{}) <- arg
-> thing_inside
VACall _ _ _
- | XExpr (ExpandedThingRn o _) <- arg
+ | XExpr (ExpandedThingRn o _ _) <- arg
, isHsThingRnStmt o || isHsThingRnPat o
-> thing_inside
@@ -951,7 +951,7 @@ expr_to_type earg =
| otherwise = not_in_scope
where occ = occName rdr
not_in_scope = failWith $ mkTcRnNotInScope rdr NotInScope
- go (L l (XExpr (ExpandedThingRn (OrigExpr orig) _))) =
+ go (L l (XExpr (ExpandedThingRn (OrigExpr orig) _ _))) =
-- Use the original, user-written expression (before expansion).
-- Example. Say we have vfun :: forall a -> blah
-- and the call vfun (Maybe [1,2,3])
=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -86,7 +86,7 @@ expand_do_stmts flav [stmt@(L loc (LastStmt _ (L body_loc body) _ ret_expr))]
-- 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 $ mkExpandedStmtPopAt loc stmt flav body
+ = return $ mkExpandedStmtPopAt loc stmt flav TcExpr body
| SyntaxExprRn ret <- ret_expr
--
@@ -94,7 +94,7 @@ 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 $ mkExpandedStmtPopAt loc stmt flav expansion
+ return $ mkExpandedStmtPopAt loc stmt flav TcApp expansion
expand_do_stmts doFlavour (stmt@(L loc (LetStmt _ bs)) : lstmts) =
-- See Note [Expanding HsDo with XXExprGhcRn] Equation (3) below
@@ -103,7 +103,7 @@ expand_do_stmts doFlavour (stmt@(L loc (LetStmt _ bs)) : lstmts) =
-- let x = e ; stmts ~~> let x = e in stmts'
do expand_stmts <- expand_do_stmts doFlavour lstmts
let expansion = genHsLet bs expand_stmts
- return $ mkExpandedStmtPopAt loc stmt doFlavour expansion
+ return $ mkExpandedStmtPopAt loc stmt doFlavour TcApp expansion
expand_do_stmts doFlavour (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
| SyntaxExprRn bind_op <- xbsrn_bindOp xbsrn
@@ -119,7 +119,7 @@ expand_do_stmts doFlavour (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
let expansion = genHsExpApps bind_op -- (>>=)
[ e
, failable_expr ]
- return $ mkExpandedStmtPopAt loc stmt doFlavour expansion
+ return $ mkExpandedStmtPopAt loc stmt doFlavour TcApp expansion
| otherwise
= pprPanic "expand_do_stmts: The impossible happened, missing bind operator from renamer" (text "stmt" <+> ppr stmt)
@@ -134,7 +134,7 @@ expand_do_stmts doFlavour (stmt@(L loc (BodyStmt _ e (SyntaxExprRn then_op) _))
let expansion = genHsExpApps then_op -- (>>)
[ e
, expand_stmts_expr ]
- return $ mkExpandedStmtPopAt loc stmt doFlavour expansion
+ return $ mkExpandedStmtPopAt loc stmt doFlavour TcApp expansion
expand_do_stmts doFlavour
((L loc (RecStmt { recS_stmts = L stmts_loc rec_stmts
@@ -227,7 +227,7 @@ expand_do_stmts doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join))): lst
, arg_expr = (L rhs_loc rhs)
, is_body_stmt = is_body_stmt
}) =
- do let xx_expr = mkExpandedStmtAt rhs_loc stmt doFlavour rhs
+ do let xx_expr = mkExpandedStmtAt rhs_loc stmt doFlavour TcExpr rhs
traceTc "do_arg" (text "OneArg" <+> vcat [ppr pat, ppr xx_expr])
return ((pat, mb_fail_op)
, xx_expr)
@@ -243,7 +243,7 @@ expand_do_stmts doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join))): lst
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)
+ XExpr (ExpandedThingRn (OrigStmt s _) _ _) -> Just (doFlavour, s)
_ -> Nothing
mk_apps :: LHsExpr GhcRn -> (SyntaxExprRn, LHsExpr GhcRn) -> LHsExpr GhcRn
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -90,6 +90,7 @@ import GHC.Utils.Panic
import Control.Monad
import qualified Data.List.NonEmpty as NE
+import qualified GHC.LanguageExtensions as LangExt
{-
************************************************************************
@@ -710,7 +711,7 @@ tcXExpr (PopErrCtxt (L loc e)) res_ty
setSrcSpanA loc $
tcExpr e res_ty
-tcXExpr xe@(ExpandedThingRn o e') res_ty
+tcXExpr xe@(ExpandedThingRn o e' tc_info) res_ty
| OrigStmt ls@(L loc s at LetStmt{}) flav <- o
, HsLet x binds e <- e'
= do { (binds', wrapper, e') <- setSrcSpanA loc $
@@ -720,17 +721,15 @@ tcXExpr xe@(ExpandedThingRn o e') res_ty
-- a duplicate error context
; return $ mkExpandedStmtTc ls flav (HsLet x binds' (mkLHsWrap wrapper e'))
}
- | OrigStmt ls@(L loc s at LastStmt{}) flav <- o
- = setSrcSpanA loc $
- addStmtCtxt s flav $
- mkExpandedStmtTc ls flav <$> tcExpr e' res_ty
- -- It is important that we call tcExpr (and not tcApp) here as
- -- `e` is the last statement's body expression
- -- and not a HsApp of a generated (>>) or (>>=)
- -- This improves error messages e.g. tests: DoExpansion1, DoExpansion2, DoExpansion3
+ | OrigStmt ls@(L loc s) flav <- o
+ , TcExpr <- tc_info
+ = setSrcSpanA loc $
+ addStmtCtxt s flav $
+ mkExpandedStmtTc ls flav <$> tcExpr e' res_ty
| OrigStmt ls@(L loc _) flav <- o
+ , TcApp <- tc_info
= setSrcSpanA loc $
- mkExpandedStmtTc ls flav <$> tcApp (XExpr xe) res_ty
+ mkExpandedStmtTc ls flav <$> tcApp (XExpr xe) res_ty
tcXExpr xe res_ty = tcApp (XExpr xe) res_ty
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -293,7 +293,7 @@ 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 _))
+ top_ctxt n (XExpr (ExpandedThingRn o _ _))
| OrigExpr fun <- o = VACall fun n noSrcSpan
top_ctxt n other_fun = VACall other_fun n noSrcSpan
@@ -318,7 +318,7 @@ splitHsApps e = go e (top_ctxt 0 e) []
HsQuasiQuote _ _ (L l _) -> set l ctxt -- l :: SrcAnn NoEpAnns
-- See Note [Looking through ExpandedThingRn]
- go (XExpr (ExpandedThingRn o e)) ctxt args
+ go (XExpr (ExpandedThingRn o e _)) ctxt args
| isHsThingRnExpr o
= go e (VAExpansion o (appCtxtLoc ctxt) (appCtxtLoc ctxt))
(EWrap (EExpand o) : args)
@@ -1606,8 +1606,7 @@ addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt e thing_inside
= case e of
HsUnboundVar {} -> thing_inside
- XExpr (ExpandedThingRn (OrigStmt stmt flav) _) -> addStmtCtxt (unLoc stmt) flav thing_inside
- -- XExpr (PopErrCtxt (L _ e)) -> 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
-- f x = _
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -751,9 +751,9 @@ exprCtOrigin (HsUntypedSplice {}) = Shouldn'tHappenOrigin "TH untyped splice"
exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc"
exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression"
exprCtOrigin (HsEmbTy {}) = Shouldn'tHappenOrigin "type expression"
-exprCtOrigin (XExpr (ExpandedThingRn thing _)) | OrigExpr a <- thing = exprCtOrigin a
- | OrigStmt _ _ <- thing = DoOrigin
- | OrigPat p _ <- thing = DoPatOrigin p
+exprCtOrigin (XExpr (ExpandedThingRn thing _ _)) | OrigExpr a <- thing = exprCtOrigin a
+ | OrigStmt _ _ <- thing = DoOrigin
+ | OrigPat p _ <- thing = DoPatOrigin p
exprCtOrigin (XExpr (PopErrCtxt {})) = Shouldn'tHappenOrigin "PopErrCtxt"
-- | Extract a suitable CtOrigin from a MatchGroup
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8e7fd9c08c8503094e4e72885315074899cca979
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8e7fd9c08c8503094e4e72885315074899cca979
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/20240527/a27b6662/attachment-0001.html>
More information about the ghc-commits
mailing list