[Git][ghc/ghc][wip/expansions-appdo] add location information to expanded expression
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Mon Jul 29 14:59:52 UTC 2024
Apoorv Ingle pushed to branch wip/expansions-appdo at Glasgow Haskell Compiler / GHC
Commits:
dc9ab2da by Apoorv Ingle at 2024-07-29T09:59:33-05:00
add location information to expanded expression
- - - - -
7 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Rename/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
=====================================
@@ -476,7 +476,7 @@ type instance XXExpr GhcTc = XXExprGhcTc
-- | The different source constructs that we use to instantiate the "original" field
-- in an `XXExprGhcRn original expansion`
-- See Note [Handling overloaded and rebindable constructs] in `GHC.Rename.Expr`
-data HsThingRn = OrigExpr (HsExpr GhcRn) -- ^ The source, user written, expression
+data HsThingRn = OrigExpr (HsExpr GhcRn) -- ^ The source, user written, expression
| OrigStmt (ExprLStmt GhcRn) HsDoFlavour -- ^ which kind of do-block did this statement come from
| OrigPat (LPat GhcRn) -- ^ The source, user written, pattern
HsDoFlavour -- ^ which kind of do-block did this statement come from
@@ -494,7 +494,7 @@ isHsThingRnPat _ = False
data XXExprGhcRn
= ExpandedThingRn { xrn_orig :: HsThingRn -- The original source thing to be used for error messages
- , xrn_expanded :: HsExpr GhcRn -- The compiler generated expanded thing
+ , xrn_expanded :: LHsExpr GhcRn -- The expanded thing can be user written or compiler generated
, xrn_doTcApp :: Bool } -- A Hint to the type checker of how to proceed
-- True <=> use GHC.Tc.Gen.Expr.tcApp on xrn_expanded
-- False <=> use GHC.Tc.Gen.Expr.tcExpr on xrn_expanded
@@ -519,7 +519,7 @@ mkPopErrCtxtExprAt loc a = L loc $ mkPopErrCtxtExpr a
-- expanded expressions.
mkExpandedExpr
:: HsExpr GhcRn -- ^ source expression
- -> HsExpr GhcRn -- ^ expanded expression
+ -> LHsExpr GhcRn -- ^ expanded expression
-> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
mkExpandedExpr oExpr eExpr = XExpr (ExpandedThingRn { xrn_orig = OrigExpr oExpr
, xrn_expanded = eExpr
@@ -532,7 +532,7 @@ mkExpandedStmt
:: ExprLStmt GhcRn -- ^ source statement
-> HsDoFlavour -- ^ source statement do flavour
-> Bool -- ^ should this be type checked using tcApp?
- -> HsExpr GhcRn -- ^ expanded expression
+ -> LHsExpr GhcRn -- ^ expanded expression
-> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
mkExpandedStmt oStmt flav doTcApp eExpr = XExpr (ExpandedThingRn { xrn_orig = OrigStmt oStmt flav
, xrn_expanded = eExpr
@@ -542,7 +542,7 @@ mkExpandedPatRn
:: LPat GhcRn -- ^ source pattern
-> HsDoFlavour -- ^ source statement do flavour
-> Maybe (ExprLStmt GhcRn) -- ^ pattern statement origin
- -> HsExpr GhcRn -- ^ expanded expression
+ -> LHsExpr 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
@@ -553,17 +553,17 @@ mkExpandedPatRn oPat flav mb_stmt eExpr = XExpr (ExpandedThingRn { xrn_orig = Or
-- expanded expression and associate it with a provided location
mkExpandedStmtAt
:: Bool -- ^ Wrap this expansion with a pop?
- -> SrcSpanAnnA -- ^ Location for the expansion expression
-> ExprLStmt GhcRn -- ^ source statement
-> HsDoFlavour -- ^ the flavour of the statement
-> Bool -- ^ should type check with tcApp?
- -> HsExpr GhcRn -- ^ expanded expression
+ -> LHsExpr GhcRn -- ^ expanded expression
-> LHsExpr GhcRn -- ^ suitably wrapped located 'XXExprGhcRn'
-mkExpandedStmtAt addPop loc oStmt flav doTcApp eExpr
+mkExpandedStmtAt addPop oStmt flav doTcApp eExpr
| addPop
- = mkPopErrCtxtExprAt loc (L loc $ mkExpandedStmt oStmt flav doTcApp eExpr)
+ = L (noAnnSrcSpan generatedSrcSpan) (mkPopErrCtxtExpr (L (noAnnSrcSpan generatedSrcSpan)
+ $ mkExpandedStmt oStmt flav doTcApp eExpr))
| otherwise
- = L loc $ mkExpandedStmt oStmt flav doTcApp eExpr
+ = L (noAnnSrcSpan generatedSrcSpan) (mkExpandedStmt oStmt flav doTcApp eExpr)
data XXExprGhcTc
= WrapExpr -- Type and evidence application and abstractions
@@ -572,7 +572,7 @@ data XXExprGhcTc
| ExpandedThingTc -- See Note [Rebindable syntax and XXExprGhcRn]
-- See Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do`
{ xtc_orig :: HsThingRn -- The original user written thing
- , xtc_expanded :: HsExpr GhcTc } -- The expanded typechecked expression
+ , xtc_expanded :: HsExpr GhcTc } -- The expanded typechecked expression
| ConLikeTc -- Result of typechecking a data-con
-- See Note [Typechecking data constructors] in
@@ -607,7 +607,7 @@ mkExpandedExprTc oExpr eExpr = XExpr (ExpandedThingTc (OrigExpr oExpr) eExpr)
-- expanded typechecked expression.
mkExpandedStmtTc
:: ExprLStmt GhcRn -- ^ source do statement
- -> HsDoFlavour
+ -> HsDoFlavour -- ^ the flavour of this statement
-> HsExpr GhcTc -- ^ expanded typechecked expression
-> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcRn'
mkExpandedStmtTc oStmt flav eExpr = XExpr (ExpandedThingTc (OrigStmt oStmt flav) eExpr)
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -1683,7 +1683,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 (L _ x) _))
| OrigExpr e <- o
= do { rebindable_on <- lift $ xoptM LangExt.RebindableSyntax
; if rebindable_on -- See Note [Quotation and rebindable syntax]
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -360,7 +360,7 @@ rnExpr (HsUnboundVar _ v)
rnExpr (HsOverLabel src v)
= do { (from_label, fvs) <- lookupSyntaxName fromLabelClassOpName
; return ( mkExpandedExpr (HsOverLabel src v) $
- HsAppType noExtField (genLHsVar from_label) hs_ty_arg
+ wrapGenSpan (HsAppType noExtField (genLHsVar from_label) hs_ty_arg)
, fvs ) }
where
hs_ty_arg = mkEmptyWildCardBndrs $ wrapGenSpan $
@@ -435,7 +435,7 @@ rnExpr (HsGetField _ e f)
; let f' = rnDotFieldOcc f
; return ( mkExpandedExpr
(HsGetField noExtField e f')
- (mkGetField getField e (fmap (unLoc . dfoLabel) f'))
+ (wrapGenSpan (mkGetField getField e (fmap (unLoc . dfoLabel) f')))
, fv_e `plusFV` fv_getField ) }
rnExpr (HsProjection _ fs)
@@ -444,7 +444,7 @@ rnExpr (HsProjection _ fs)
; let fs' = fmap rnDotFieldOcc fs
; return ( mkExpandedExpr
(HsProjection noExtField fs')
- (mkProjection getField circ (fmap (fmap (unLoc . dfoLabel)) fs'))
+ (wrapGenSpan ((mkProjection getField circ (fmap (fmap (unLoc . dfoLabel)) fs'))))
, unitFV circ `plusFV` fv_getField) }
------------------------------------------
@@ -516,7 +516,7 @@ rnExpr (ExplicitList _ exps)
lit_n = mkIntegralLit (length exps)
hs_lit = genHsIntegralLit lit_n
exp_list = genHsApps' (L (noAnnSrcSpan loc) from_list_n_name) [hs_lit, wrapGenSpan rn_list]
- ; return ( mkExpandedExpr rn_list exp_list
+ ; return ( mkExpandedExpr rn_list (wrapGenSpan exp_list)
, fvs `plusFV` fvs') } }
rnExpr (ExplicitTuple _ tup_args boxity)
@@ -578,7 +578,7 @@ rnExpr (RecordUpd { rupd_expr = L l expr, rupd_flds = rbinds })
, olRecUpdFields = us }
; return ( mkExpandedExpr
(RecordUpd noExtField (L l e) upd_flds)
- (mkRecordDotUpd getField setField (L l e) us)
+ (wrapGenSpan $ mkRecordDotUpd getField setField (L l e) us)
, plusFVs [fv_getField, fv_setField, fv_e, fv_us] ) }
rnExpr (HsRecSel x _) = dataConCantHappen x
@@ -669,17 +669,17 @@ rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
-- See Note [Parsing sections] in GHC.Parser
-- Also see Note [Handling overloaded and rebindable constructs]
-rnSection section@(SectionR x op expr)
+rnSection section@(SectionR x op@(L op_loc _) expr@(L expr_loc _))
-- See Note [Left and right sections]
= do { (op', fvs_op) <- rnLExpr op
; (expr', fvs_expr) <- rnLExpr expr
; checkSectionPrec InfixR section op' expr'
; let rn_section = SectionR x op' expr'
- ds_section = genHsApps rightSectionName [op',expr']
+ ds_section = L (combineSrcSpansA op_loc expr_loc) (genHsApps rightSectionName [op',expr'])
; return ( mkExpandedExpr rn_section ds_section
, fvs_op `plusFV` fvs_expr) }
-rnSection section@(SectionL x expr op)
+rnSection section@(SectionL x expr@(L expr_loc _) op@(L op_loc _))
-- See Note [Left and right sections]
= do { (expr', fvs_expr) <- rnLExpr expr
; (op', fvs_op) <- rnLExpr op
@@ -691,7 +691,7 @@ rnSection section@(SectionL x expr op)
| postfix_ops = HsApp noExtField op' expr'
| otherwise = genHsApps leftSectionName
[wrapGenSpan $ HsApp noExtField op' expr']
- ; return ( mkExpandedExpr rn_section ds_section
+ ; return ( mkExpandedExpr rn_section (L (combineSrcSpansA expr_loc op_loc) ds_section)
, fvs_op `plusFV` fvs_expr) }
rnSection other = pprPanic "rnSection" (ppr other)
@@ -2806,7 +2806,7 @@ rnHsIf p b1 b2
-> return (rn_if, fvs_if)
Just ite_name -- Rebindable-syntax case
- -> do { let ds_if = genHsApps ite_name [p', b1', b2']
+ -> do { let ds_if = wrapGenSpan (genHsApps ite_name [p', b1', b2'])
fvs = plusFVs [fvs_if, unitFV ite_name]
; return (mkExpandedExpr rn_if ds_if, fvs) } }
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -874,7 +874,7 @@ looks_like_type_arg _ = False
addArgCtxt :: AppCtxt -> LHsExpr GhcRn
-> TcM a -> TcM a
--- There are four cases:
+-- There are three cases:
-- 1. In the normal case, we add an informative context
-- "In the third argument of f, namely blah"
-- 2. If we are deep inside generated code (`isGeneratedCode` is `True`)
@@ -883,18 +883,10 @@ addArgCtxt :: AppCtxt -> LHsExpr GhcRn
-- "In the expression: arg"
-- Unless the arg is also a generated thing, in which case do nothing.
-- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr
--- 3. We are in an expanded `do`-block's non-bind statement
+-- 3. We are in an expanded `do`-block's statement
-- we simply add the statement context
-- "In the statement of the `do`-block .."
--- 4. We are in an expanded do block's bind statement
--- a. Then either we are typechecking the first argument of the bind which is user located
--- so we set the location to be that of the argument
--- b. Or, we are typechecking the second argument which would be a generated lambda
--- so we set the location to be whatever the location in the context is
-- See Note [Expanding HsDo with XXExprGhcRn] in GHC.Tc.Gen.Do
--- For future: we need a cleaner way of doing this bit of adding the right error context.
--- There is a delicate dance of looking at source locations and reconstructing
--- whether the piece of code is a `do`-expanded code or some other expanded code.
addArgCtxt ctxt (L arg_loc arg) thing_inside
= do { in_generated_code <- inGeneratedCode
; case ctxt of
@@ -903,18 +895,10 @@ 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 loc stmt) flav) _ _
-> setSrcSpanA loc $
addStmtCtxt stmt flav $
+ setSrcSpanA arg_loc $
thing_inside
_ -> setSrcSpanA arg_loc $
=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -73,13 +73,13 @@ expand_do_stmts _ _ (stmt@(L _ (ParStmt {})):_) =
pprPanic "expand_do_stmts: ParStmt" $ ppr stmt
-- handeled by `GHC.Tc.Gen.Match.tcLcStmt`
-expand_do_stmts addPop flav [stmt@(L loc (LastStmt _ (L body_loc body) _ ret_expr))]
+expand_do_stmts addPop flav [stmt@(L _ (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 addPop loc stmt flav False body
+ = return $ mkExpandedStmtAt addPop stmt flav False (L body_loc body)
| SyntaxExprRn ret <- ret_expr
--
@@ -87,18 +87,18 @@ 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 False expansion
+ return $ mkExpandedStmtAt addPop stmt flav False (L body_loc expansion)
-expand_do_stmts addPop doFlavour (stmt@(L loc (LetStmt _ bs)) : lstmts) =
+expand_do_stmts addPop 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'
do expand_stmts <- expand_do_stmts True doFlavour lstmts
let expansion = genHsLet bs expand_stmts
- return $ mkExpandedStmtAt addPop loc stmt doFlavour False expansion
+ return $ mkExpandedStmtAt addPop stmt doFlavour False (wrapGenSpan expansion)
-expand_do_stmts addPop doFlavour (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
+expand_do_stmts addPop doFlavour (stmt@(L _ (BindStmt xbsrn pat e)): lstmts)
| SyntaxExprRn bind_op <- xbsrn_bindOp xbsrn
, fail_op <- xbsrn_failOp xbsrn
-- See Note [Expanding HsDo with XXExprGhcRn] Equation (2) below
@@ -112,12 +112,12 @@ 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 True expansion
+ return $ mkExpandedStmtAt addPop stmt doFlavour True (wrapGenSpan expansion)
| otherwise
= pprPanic "expand_do_stmts: The impossible happened, missing bind operator from renamer" (text "stmt" <+> ppr stmt)
-expand_do_stmts addPop doFlavour (stmt@(L loc (BodyStmt _ e (SyntaxExprRn then_op) _)) : lstmts) =
+expand_do_stmts addPop doFlavour (stmt@(L _ (BodyStmt _ e (SyntaxExprRn then_op) _)) : lstmts) =
-- See Note [BodyStmt] in Language.Haskell.Syntax.Expr
-- See Note [Expanding HsDo with XXExprGhcRn] Equation (1) below
-- stmts ~~> stmts'
@@ -127,7 +127,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 True expansion
+ return $ mkExpandedStmtAt addPop stmt doFlavour True (wrapGenSpan expansion)
expand_do_stmts _ doFlavour
((L loc (RecStmt { recS_stmts = L stmts_loc rec_stmts
@@ -216,7 +216,7 @@ expand_do_stmts addPop doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join)
{ xarg_app_arg_one = mb_fail_op
, app_arg_pattern = pat
, arg_expr = (L rhs_loc rhs) }) =
- do let xx_expr = mkExpandedStmtAt addPop (noAnnSrcSpan generatedSrcSpan) stmt doFlavour False rhs
+ do let xx_expr = mkExpandedStmtAt addPop stmt doFlavour False (L rhs_loc rhs)
traceTc "do_arg" (text "OneArg" <+> vcat [ppr pat, ppr xx_expr])
return ((pat, mb_fail_op)
, xx_expr)
@@ -247,7 +247,7 @@ expand_do_stmts _ _ stmts = pprPanic "expand_do_stmts: impossible happened" $ (p
-- checks the pattern `pat` for irrefutability which decides if we need to wrap it with a fail block
mk_failable_expr :: Bool -> HsDoFlavour -> Maybe (ExprLStmt GhcRn) -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn)
-mk_failable_expr addPop doFlav mb_stmt lpat@(L loc pat) expr fail_op =
+mk_failable_expr addPop doFlav mb_stmt lpat@(L _ pat) expr fail_op =
do { is_strict <- xoptM LangExt.Strict
; rdrEnv <- getGlobalRdrEnv
; comps <- getCompleteMatchesTcM
@@ -262,21 +262,21 @@ mk_failable_expr addPop 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 -> mkExpandedStmtAt addPop (noAnnSrcSpan generatedSrcSpan) s doFlav False
- (unLoc $ (genHsLamDoExp doFlav [lpat]
- $ wrapGenSpan (mkPopErrCtxtExpr expr)))
- else L loc <$> mk_fail_block doFlav mb_stmt lpat expr fail_op
+ Just stmt -> mkExpandedStmtAt addPop stmt doFlav False
+ (genHsLamDoExp doFlav [lpat]
+ $ wrapGenSpan (mkPopErrCtxtExpr expr))
+ else mk_fail_block doFlav mb_stmt lpat expr fail_op
}
-- makes the fail block with a given fail_op
mk_fail_block :: HsDoFlavour -> Maybe (ExprLStmt GhcRn)
- -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (HsExpr GhcRn)
+ -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn)
mk_fail_block doFlav mb_stmt pat@(L ploc _) e (Just (SyntaxExprRn fail_op)) =
do dflags <- getDynFlags
- return $ HsLam noAnn LamCases $ mkMatchGroup (doExpansionOrigin doFlav) -- \
- (wrapGenSpan [ genHsCaseAltDoExp doFlav pat e -- pat -> expr
- , fail_alt_case dflags pat fail_op -- _ -> fail "fail pattern"
- ])
+ return $ wrapGenSpan (HsLam noAnn LamCases $ mkMatchGroup (doExpansionOrigin doFlav) -- \
+ (wrapGenSpan [ genHsCaseAltDoExp doFlav pat e -- pat -> expr
+ , fail_alt_case dflags pat fail_op -- _ -> fail "fail pattern"
+ ]))
where
fail_alt_case :: DynFlags -> LPat GhcRn -> HsExpr GhcRn -> LMatch GhcRn (LHsExpr GhcRn)
fail_alt_case dflags pat fail_op = genHsCaseAltDoExp doFlav (L ploc $ WildPat noExtField) $
@@ -285,7 +285,7 @@ mk_fail_block doFlav mb_stmt pat@(L ploc _) e (Just (SyntaxExprRn fail_op)) =
fail_op_expr :: DynFlags -> LPat GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
fail_op_expr dflags pat fail_op
= mkExpandedPatRn pat doFlav mb_stmt $
- genHsApp fail_op (mk_fail_msg_expr dflags pat)
+ wrapGenSpan (genHsApp fail_op (mk_fail_msg_expr dflags pat))
mk_fail_msg_expr :: DynFlags -> LPat GhcRn -> LHsExpr GhcRn
mk_fail_msg_expr dflags pat
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -621,7 +621,7 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr
-- Typecheck the expanded expression.
; expr' <- addErrCtxt err_ctxt $
- tcExpr (mkExpandedExpr expr ds_expr) (Check ds_res_ty)
+ tcExpr (mkExpandedExpr expr (wrapGenSpan ds_expr)) (Check ds_res_ty)
-- NB: it's important to use ds_res_ty and not res_ty here.
-- Test case: T18802b.
@@ -714,7 +714,7 @@ tcXExpr (PopErrCtxt (L loc e)) res_ty
setSrcSpanA loc $
tcExpr e res_ty
-tcXExpr xe@(ExpandedThingRn o e' doTcApp) res_ty
+tcXExpr xe@(ExpandedThingRn o (L _ e') doTcApp) res_ty
| OrigPat (L loc _) flav (Just s) <- o -- testcase T16628
= setSrcSpanA loc $
addStmtCtxt (unLoc s) flav $
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -325,8 +325,8 @@ 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 e (VAExpansion o (appCtxtLoc ctxt) (appCtxtLoc ctxt))
+ go (XExpr (ExpandedThingRn o (L l e) _)) _ args
+ = go e (VAExpansion o (locA l) (locA l))
(EWrap (EExpand o) : args)
-- See Note [Desugar OpApp in the typechecker]
@@ -335,7 +335,7 @@ splitHsApps e = go e (top_ctxt 0 e) []
, mkEValArg (VACall op 1 generatedSrcSpan) arg1
: mkEValArg (VACall op 2 generatedSrcSpan) arg2
-- generatedSrcSpan because this the span of the call,
- -- and its hard to say exactly what that is
+ -- Exand its hard to say exactly what that is
: EWrap (EExpand (OrigExpr e))
: args )
@@ -555,20 +555,25 @@ tcInferAppHead_maybe fun
_ -> return Nothing
addHeadCtxt :: AppCtxt -> TcM a -> TcM a
-addHeadCtxt (VAExpansion (OrigStmt (L loc stmt) flav) _ _) thing_inside =
- do setSrcSpanA loc $
- addStmtCtxt stmt flav
- thing_inside
addHeadCtxt fun_ctxt thing_inside
+ | isGeneratedSrcSpan fun_loc
+ = case fun_ctxt of
+ VAExpansion (OrigStmt (L loc stmt) flav) _ _
+ -> do setSrcSpanA loc $
+ addStmtCtxt stmt flav $
+ thing_inside
+ VAExpansion (OrigPat (L loc _) _ _) _ _
+ -> setSrcSpanA loc $ thing_inside
+ _ -> thing_inside
+
| not (isGoodSrcSpan fun_loc) -- noSrcSpan => no arguments
= thing_inside -- => context is already set
| otherwise
= setSrcSpan fun_loc $
- do case fun_ctxt of
+ do traceTc "addHeadCtxt: fun_loc" (ppr fun_loc)
+ case fun_ctxt of
VAExpansion (OrigExpr orig) _ _
-> addExprCtxt orig thing_inside
- VAExpansion (OrigPat _ flav (Just (L loc stmt))) _ _
- -> setSrcSpanA loc $ addStmtCtxt stmt flav thing_inside
_ -> thing_inside
where
fun_loc = appCtxtLoc fun_ctxt
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dc9ab2dae0f8b2d3b3fbdea5e6cad089e6f739c6
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dc9ab2dae0f8b2d3b3fbdea5e6cad089e6f739c6
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/20240729/c1ef43b7/attachment-0001.html>
More information about the ghc-commits
mailing list