[Git][ghc/ghc][wip/expansions-appdo] simplify data structures. remove doTcApp and applicative stmt fail blocks do not refer stmts
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Mon Sep 9 04:46:28 UTC 2024
Apoorv Ingle pushed to branch wip/expansions-appdo at Glasgow Haskell Compiler / GHC
Commits:
1f024c7e by Apoorv Ingle at 2024-09-08T23:46:08-05:00
simplify data structures. remove doTcApp and applicative stmt fail blocks do not refer stmts
- - - - -
8 changed files:
- compiler/GHC/Hs/Expr.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
- testsuite/tests/ghci.debugger/scripts/break029.script
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -496,7 +496,6 @@ data HsThingRn = OrigExpr (HsExpr GhcRn) -- ^ The source, user wr
| 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
- (Maybe (ExprLStmt GhcRn)) -- ^ Optional statement binding this pattern
isHsThingRnExpr, isHsThingRnStmt, isHsThingRnPat :: HsThingRn -> Bool
isHsThingRnExpr (OrigExpr{}) = True
@@ -511,9 +510,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_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
+ }
| PopErrCtxt -- A hint for typechecker to pop
{-# UNPACK #-} !(LHsExpr GhcRn) -- the top of the error context stack
@@ -538,8 +535,7 @@ mkExpandedExpr
-> HsExpr GhcRn -- ^ expanded expression
-> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
mkExpandedExpr oExpr eExpr = XExpr (ExpandedThingRn { xrn_orig = OrigExpr oExpr
- , xrn_expanded = eExpr
- , xrn_doTcApp = False })
+ , xrn_expanded = eExpr })
-- | Build an expression using the extension constructor `XExpr`,
-- and the two components of the expansion: original do stmt and
@@ -547,22 +543,18 @@ mkExpandedExpr oExpr eExpr = XExpr (ExpandedThingRn { xrn_orig = OrigExpr oExpr
mkExpandedStmt
:: ExprLStmt GhcRn -- ^ source statement
-> 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 doTcApp eExpr = XExpr (ExpandedThingRn { xrn_orig = OrigStmt oStmt flav
- , xrn_expanded = eExpr
- , xrn_doTcApp = doTcApp})
+mkExpandedStmt oStmt flav eExpr = XExpr (ExpandedThingRn { xrn_orig = OrigStmt oStmt flav
+ , xrn_expanded = eExpr })
mkExpandedPatRn
:: LPat GhcRn -- ^ source pattern
-> 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_doTcApp = False})
+mkExpandedPatRn oPat flav eExpr = XExpr (ExpandedThingRn { xrn_orig = OrigPat oPat flav
+ , xrn_expanded = eExpr })
-- | Build an expression using the extension constructor `XExpr`,
-- and the two components of the expansion: original do stmt and
@@ -572,14 +564,13 @@ mkExpandedStmtAt
-> 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 -- ^ suitably wrapped located 'XXExprGhcRn'
-mkExpandedStmtAt addPop loc oStmt flav doTcApp eExpr
+mkExpandedStmtAt addPop loc oStmt flav eExpr
| addPop
- = mkPopErrCtxtExprAt loc (L loc $ mkExpandedStmt oStmt flav doTcApp eExpr)
+ = mkPopErrCtxtExprAt loc (L loc $ mkExpandedStmt oStmt flav eExpr)
| otherwise
- = L loc $ mkExpandedStmt oStmt flav doTcApp eExpr
+ = L loc $ mkExpandedStmt oStmt flav eExpr
data XXExprGhcTc
= WrapExpr -- Type and evidence application and abstractions
@@ -888,12 +879,12 @@ instance Outputable HsThingRn where
= case thing of
OrigExpr x -> ppr_builder "<OrigExpr>:" x
OrigStmt x _ -> ppr_builder "<OrigStmt>:" x
- OrigPat x _ mb_stmt -> ifPprDebug (braces (text "<OrigPat>" <+> parens (ppr x) <+> parens (ppr mb_stmt))) (ppr x)
+ OrigPat x _ -> ifPprDebug (braces (text "<OrigPat>" <+> parens (ppr x))) (ppr x)
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))
@@ -933,7 +924,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
@@ -1047,7 +1038,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
@@ -1099,7 +1090,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/HsToCore/Quote.hs
=====================================
@@ -1684,7 +1684,6 @@ repE (HsProjection _ xs) = repProjection (fmap (field_label . unLoc . dfoLabel .
repE (HsEmbTy _ t) = do
t1 <- repLTy (hswc_body t)
rep2 typeEName [unC t1]
-
repE (HsQual _ (L _ ctx) body) = do
ctx' <- repLEs ctx
body' <- repLE body
@@ -1704,7 +1703,7 @@ repE (HsFunArr _ mult arg res) = do
arg' <- repLE arg
res' <- repLE res
repApps fun [arg', res']
-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
=====================================
@@ -651,7 +651,7 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
where
fun_orig = case fun_ctxt of
VAExpansion (OrigStmt{}) _ _ -> DoOrigin
- VAExpansion (OrigPat pat _ _) _ _ -> DoPatOrigin pat
+ VAExpansion (OrigPat pat _) _ _ -> DoPatOrigin pat
VAExpansion (OrigExpr e) _ _ -> exprCtOrigin e
VACall e _ _ -> exprCtOrigin e
@@ -912,6 +912,8 @@ addArgCtxt ctxt (L arg_loc arg) thing_inside
-> setSrcSpanA arg_loc $
addStmtCtxt stmt flav $
thing_inside
+ VAExpansion (OrigStmt (L _ (XStmtLR (ApplicativeStmt{}))) _) _ _
+ -> thing_inside
VAExpansion (OrigStmt (L loc stmt) flav) _ _
-> setSrcSpanA loc $
addStmtCtxt stmt flav $
@@ -1062,7 +1064,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
=====================================
@@ -79,7 +79,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 False body
+ = return $ mkExpandedStmtAt addPop loc stmt flav body
| SyntaxExprRn ret <- ret_expr
--
@@ -87,7 +87,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 False expansion
+ return $ mkExpandedStmtAt addPop loc stmt flav expansion
expand_do_stmts addPop doFlavour (stmt@(L loc (LetStmt _ bs)) : lstmts) =
-- See Note [Expanding HsDo with XXExprGhcRn] Equation (3) below
@@ -96,7 +96,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 False expansion
+ return $ mkExpandedStmtAt addPop loc stmt doFlavour expansion
expand_do_stmts addPop doFlavour (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
| SyntaxExprRn bind_op <- xbsrn_bindOp xbsrn
@@ -108,11 +108,11 @@ expand_do_stmts addPop doFlavour (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
-- -------------------------------------------------------
-- pat <- e ; stmts ~~> (>>=) e f
= do expand_stmts <- expand_do_stmts True doFlavour lstmts
- failable_expr <- mk_failable_expr False doFlavour Nothing pat expand_stmts fail_op
+ failable_expr <- mk_failable_expr False doFlavour pat expand_stmts fail_op
let expansion = genHsExpApps bind_op -- (>>=)
[ e
, failable_expr ]
- return $ mkExpandedStmtAt addPop loc stmt doFlavour True expansion
+ return $ mkExpandedStmtAt addPop loc stmt doFlavour expansion
| otherwise
= pprPanic "expand_do_stmts: The impossible happened, missing bind operator from renamer" (text "stmt" <+> ppr stmt)
@@ -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 loc stmt doFlavour expansion
expand_do_stmts _ doFlavour
((L loc (RecStmt { recS_stmts = L stmts_loc rec_stmts
@@ -193,7 +193,7 @@ expand_do_stmts addPop doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join)
; (pats_can_fail, rhss) <- unzip <$> mapM (do_arg . snd) args
-- add blocks for failable patterns
- ; body_with_fails <- foldrM match_args xexpr (zip pats_can_fail rhss)
+ ; body_with_fails <- foldrM match_args xexpr pats_can_fail
-- builds (((body <$> e1) <*> e2) ...)
; let expand_ado_expr = foldl mk_apps body_with_fails (zip (map fst args) rhss)
@@ -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 (noAnnSrcSpan generatedSrcSpan) stmt doFlavour rhs
traceTc "do_arg" (text "OneArg" <+> vcat [ppr pat, ppr xx_expr])
return ((pat, mb_fail_op)
, xx_expr)
@@ -230,12 +230,8 @@ expand_do_stmts addPop doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join)
; return ((pat, Nothing)
, xx_expr) }
- match_args :: ((LPat GhcRn, FailOperator GhcRn), LHsExpr GhcRn) -> LHsExpr GhcRn -> TcM (LHsExpr GhcRn)
- match_args ((pat, fail_op), stmt_expr) body = mk_failable_expr addPop doFlavour mb_stmt pat body fail_op
- where mb_stmt = case unLoc stmt_expr of
- XExpr (ExpandedThingRn (OrigStmt s _) _ _) -> Just s
- XExpr (PopErrCtxt (L _ (XExpr (ExpandedThingRn (OrigStmt s _) _ _)))) -> Just s
- _ -> Nothing
+ match_args :: (LPat GhcRn, FailOperator GhcRn) -> LHsExpr GhcRn -> TcM (LHsExpr GhcRn)
+ match_args (pat, fail_op) body = mk_failable_expr addPop doFlavour pat body fail_op
mk_apps :: LHsExpr GhcRn -> (SyntaxExprRn, LHsExpr GhcRn) -> LHsExpr GhcRn
mk_apps l_expr (op, r_expr) =
@@ -246,8 +242,8 @@ expand_do_stmts addPop doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join)
expand_do_stmts _ _ stmts = pprPanic "expand_do_stmts: impossible happened" $ (ppr stmts)
-- 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 :: Bool -> HsDoFlavour -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn)
+mk_failable_expr addPop doFlav lpat@(L loc pat) expr@(L exprloc _) fail_op =
do { is_strict <- xoptM LangExt.Strict
; hscEnv <- getTopEnv
; rdrEnv <- getGlobalRdrEnv
@@ -256,23 +252,21 @@ mk_failable_expr addPop doFlav mb_stmt lpat@(L loc pat) expr fail_op =
; traceTc "mk_failable_expr" (vcat [ text "pat:" <+> ppr pat
, text "isIrrefutable:" <+> ppr irrf_pat
])
-
+ ; let xexpr | addPop = mkPopErrCtxtExprAt exprloc expr
+ | otherwise = expr
; if irrf_pat -- don't wrap with fail block if
-- the pattern is irrefutable
then case pat of
- (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
+ (WildPat{}) -> return $ genHsLamDoExp doFlav [L noSrcSpanA pat] xexpr
+ _ -> return $ genHsLamDoExp doFlav [lpat] xexpr
+
+ else L loc <$> mk_fail_block doFlav lpat expr fail_op
}
-- makes the fail block with a given fail_op
-mk_fail_block :: HsDoFlavour -> Maybe (ExprLStmt GhcRn)
+mk_fail_block :: HsDoFlavour
-> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (HsExpr GhcRn)
-mk_fail_block doFlav mb_stmt pat@(L ploc _) e (Just (SyntaxExprRn fail_op)) =
+mk_fail_block doFlav 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
@@ -285,7 +279,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 $
+ = mkExpandedPatRn pat doFlav $
genHsApp fail_op (mk_fail_msg_expr dflags pat)
mk_fail_msg_expr :: DynFlags -> LPat GhcRn -> LHsExpr GhcRn
@@ -295,7 +289,7 @@ mk_fail_block doFlav mb_stmt pat@(L ploc _) e (Just (SyntaxExprRn fail_op)) =
<+> text "at" <+> ppr (getLocA pat)
-mk_fail_block _ _ _ _ _ = pprPanic "mk_fail_block: impossible happened" empty
+mk_fail_block _ _ _ _ = pprPanic "mk_fail_block: impossible happened" empty
{- Note [Expanding HsDo with XXExprGhcRn]
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -717,15 +717,10 @@ tcXExpr (PopErrCtxt (L loc e)) res_ty
setSrcSpanA loc $
tcExpr e res_ty
-tcXExpr xe@(ExpandedThingRn o e' doTcApp) res_ty
- | OrigPat (L loc _) flav (Just s) <- o -- testcase T16628
- = setSrcSpanA loc $
- addStmtCtxt (unLoc s) flav $
- tcApp (XExpr xe) res_ty
-
+tcXExpr xe@(ExpandedThingRn o e') res_ty
| OrigStmt ls@(L loc s) flav <- o
, HsLet x binds e <- e'
- = do { (binds', wrapper, e') <- setSrcSpanA loc $
+ = do { (binds', wrapper, e') <- setSrcSpanA loc $
addStmtCtxt s flav $
tcLocalBinds binds $
tcMonoExprNC e res_ty -- NB: Do not call tcMonoExpr here as it adds
@@ -733,22 +728,14 @@ tcXExpr xe@(ExpandedThingRn o e' doTcApp) res_ty
; return $ mkExpandedStmtTc ls flav (HsLet x binds' (mkLHsWrap wrapper e'))
}
- | OrigStmt ls@(L loc _) flav <- o
- , doTcApp
+ | OrigStmt s@(L loc LastStmt{}) flav <- o
= setSrcSpanA loc $
- mkExpandedStmtTc ls flav <$> tcApp (XExpr xe) res_ty
+ addStmtCtxt (unLoc s) flav $
+ mkExpandedStmtTc s flav <$> tcApp e' res_ty
- -- There are currently 2 `do`-statements that require calling `tcExpr` and not `tcApp`:
- -- `LastStmt`, `AppStmt`
- -- The reason is that the expanded expression `e` is the last statement's body expression
- -- (or the the argument expression of an applicative statement)
- -- It is not an HsApp of a generated (>>) or (>>=)
- -- This improves error messages e.g. tests: DoExpansion1, DoExpansion2, DoExpansion3, ado002 etc.
- | OrigStmt ls@(L loc s) flav <- o
- , not doTcApp
+ | OrigStmt ls@(L loc _) flav <- o
= setSrcSpanA loc $
- addStmtCtxt s flav $
- mkExpandedStmtTc ls flav <$> tcExpr e' 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
=====================================
@@ -300,7 +300,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 (OrigExpr fun) _ _))
+ top_ctxt n (XExpr (ExpandedThingRn (OrigExpr fun) _))
= VACall fun n noSrcSpan
top_ctxt n other_fun = VACall other_fun n noSrcSpan
@@ -325,7 +325,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
= go e (VAExpansion o (appCtxtLoc ctxt) (appCtxtLoc ctxt))
(EWrap (EExpand o) : args)
@@ -567,8 +567,6 @@ addHeadCtxt fun_ctxt thing_inside
do 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
@@ -1268,7 +1266,7 @@ addExprCtxt e thing_inside
= case e of
HsUnboundVar {} -> thing_inside
XExpr (PopErrCtxt (L _ e)) -> addExprCtxt e $ thing_inside
- XExpr (ExpandedThingRn (OrigStmt stmt flav) _ _) -> addStmtCtxt (unLoc stmt) flav 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
=====================================
@@ -755,9 +755,9 @@ exprCtOrigin (HsEmbTy {}) = Shouldn'tHappenOrigin "type expression"
exprCtOrigin (HsForAll {}) = Shouldn'tHappenOrigin "forall telescope" -- See Note [Types in terms]
exprCtOrigin (HsQual {}) = Shouldn'tHappenOrigin "constraint context" -- See Note [Types in terms]
exprCtOrigin (HsFunArr {}) = Shouldn'tHappenOrigin "function arrow" -- See Note [Types in terms]
-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
=====================================
testsuite/tests/ghci.debugger/scripts/break029.script
=====================================
@@ -1,5 +1,4 @@
:load break029.hs
:step f 3
:step
-:step
y
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1f024c7ebc2988cdcf3867fed29251a36faf6d88
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1f024c7ebc2988cdcf3867fed29251a36faf6d88
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/20240909/03145d26/attachment-0001.html>
More information about the ghc-commits
mailing list