[Git][ghc/ghc][wip/spj-apporv-Oct24] 3 commits: - Remove one `SrcSpan` field from `VAExpansion`. It is no longer needed.
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Mon Mar 3 16:54:25 UTC 2025
Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC
Commits:
f5c7773f by Simon Peyton Jones at 2025-03-03T10:53:45-06:00
- Remove one `SrcSpan` field from `VAExpansion`. It is no longer needed.
- Make `tcExpr` take a `Maybe HsThingRn` which will be passed on to tcApp and used by splitHsApps to determine a more accurate `AppCtx`
- `tcXExpr` is less hacky now
This reverts commit 9648167a936a329d3876de71235f476e5836ddf8.
- - - - -
141bbcbb by Apoorv Ingle at 2025-03-03T10:54:00-06:00
do not look through HsExpansion applications
- - - - -
1229a9f1 by Apoorv Ingle at 2025-03-03T10:54:00-06:00
kill OrigPat and remove HsThingRn From VAExpansion
- - - - -
9 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
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Types/Origin.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -530,26 +530,21 @@ type instance XXExpr GhcTc = XXExprGhcTc
-- See Note [Handling overloaded and rebindable constructs] in `GHC.Rename.Expr`
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
-isHsThingRnExpr, isHsThingRnStmt, isHsThingRnPat :: HsThingRn -> Bool
+isHsThingRnExpr, isHsThingRnStmt :: HsThingRn -> Bool
isHsThingRnExpr (OrigExpr{}) = True
isHsThingRnExpr _ = False
isHsThingRnStmt (OrigStmt{}) = True
isHsThingRnStmt _ = False
-isHsThingRnPat (OrigPat{}) = True
-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
}
| PopErrCtxt -- A hint for typechecker to pop
- {-# UNPACK #-} !(LHsExpr GhcRn) -- the top of the error context stack
+ {-# UNPACK #-} !(HsExpr GhcRn) -- the top of the error context stack
-- Does not presist post renaming phase
-- See Part 3. of Note [Expanding HsDo with XXExprGhcRn]
-- in `GHC.Tc.Gen.Do`
@@ -558,15 +553,6 @@ data XXExprGhcRn
-- Note [Record selectors in the AST]
-
--- | Wrap a located expression with a `PopErrCtxt`
-mkPopErrCtxtExpr :: LHsExpr GhcRn -> HsExpr GhcRn
-mkPopErrCtxtExpr a = XExpr (PopErrCtxt a)
-
--- | Wrap a located expression with a PopSrcExpr with an appropriate location
-mkPopErrCtxtExprAt :: SrcSpanAnnA -> LHsExpr GhcRn -> LHsExpr GhcRn
-mkPopErrCtxtExprAt loc a = L loc $ mkPopErrCtxtExpr a
-
-- | Build an expression using the extension constructor `XExpr`,
-- and the two components of the expansion: original expression and
-- expanded expressions.
@@ -588,30 +574,6 @@ mkExpandedStmt
mkExpandedStmt oStmt flav eExpr = XExpr (ExpandedThingRn { xrn_orig = OrigStmt oStmt flav
, xrn_expanded = eExpr })
-mkExpandedPatRn
- :: LPat GhcRn -- ^ source pattern
- -> HsDoFlavour -- ^ source statement do flavour
- -> HsExpr GhcRn -- ^ expanded expression
- -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
-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
--- 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
- -> HsExpr GhcRn -- ^ expanded expression
- -> LHsExpr GhcRn -- ^ suitably wrapped located 'XXExprGhcRn'
-mkExpandedStmtAt addPop loc oStmt flav eExpr
- | addPop
- = mkPopErrCtxtExprAt loc (L loc $ mkExpandedStmt oStmt flav eExpr)
- | otherwise
- = L loc $ mkExpandedStmt oStmt flav eExpr
-
data XXExprGhcTc
= WrapExpr -- Type and evidence application and abstractions
HsWrapper (HsExpr GhcTc)
@@ -664,6 +626,12 @@ mkExpandedStmtTc
-> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcRn'
mkExpandedStmtTc oStmt flav eExpr = XExpr (ExpandedThingTc (OrigStmt oStmt flav) eExpr)
+mkExpandedTc
+ :: HsThingRn -- ^ source do statement
+ -> HsExpr GhcTc -- ^ expanded typechecked expression
+ -> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcRn'
+mkExpandedTc o e = XExpr (ExpandedThingTc o e)
+
{- *********************************************************************
* *
Pretty-printing expressions
@@ -918,7 +886,6 @@ instance Outputable HsThingRn where
= case thing of
OrigExpr x -> ppr_builder "<OrigExpr>:" x
OrigStmt x _ -> ppr_builder "<OrigStmt>:" 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
@@ -966,7 +933,7 @@ 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 (PopErrCtxt (L _ a)) = ppr_infix_expr a
+ppr_infix_expr_rn (PopErrCtxt a) = ppr_infix_expr a
ppr_infix_expr_rn (HsRecSelRn f) = Just (pprInfixOcc f)
ppr_infix_expr_tc :: XXExprGhcTc -> Maybe SDoc
@@ -1083,7 +1050,7 @@ hsExprNeedsParens prec = go
go_x_rn :: XXExprGhcRn -> Bool
go_x_rn (ExpandedThingRn thing _ ) = hsExpandedNeedsParens thing
- go_x_rn (PopErrCtxt (L _ a)) = hsExprNeedsParens prec a
+ go_x_rn (PopErrCtxt a) = hsExprNeedsParens prec a
go_x_rn (HsRecSelRn{}) = False
hsExpandedNeedsParens :: HsThingRn -> Bool
@@ -1135,9 +1102,9 @@ isAtomicHsExpr (XExpr x)
go_x_tc (HsRecSelTc{}) = True
go_x_rn :: XXExprGhcRn -> Bool
- go_x_rn (ExpandedThingRn thing _) = isAtomicExpandedThingRn thing
- go_x_rn (PopErrCtxt (L _ a)) = isAtomicHsExpr a
- go_x_rn (HsRecSelRn{}) = True
+ go_x_rn (ExpandedThingRn thing _) = isAtomicExpandedThingRn thing
+ go_x_rn (PopErrCtxt a) = isAtomicHsExpr a
+ go_x_rn (HsRecSelRn{}) = True
isAtomicExpandedThingRn :: HsThingRn -> Bool
isAtomicExpandedThingRn (OrigExpr e) = isAtomicHsExpr e
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -1716,7 +1716,7 @@ repE e@(XExpr (ExpandedThingRn o x))
| otherwise
= notHandled (ThExpressionForm e)
-repE (XExpr (PopErrCtxt (L _ e))) = repE e
+repE (XExpr (PopErrCtxt e)) = repE e
repE (XExpr (HsRecSelRn (FieldOcc _ (L _ x)))) = repE (HsVar noExtField (noLocA x))
repE e@(HsPragE _ (HsPragSCC {}) _) = notHandled (ThCostCentres e)
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -2267,7 +2267,7 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
-- Need 'pureAName' and not 'returnMName' here, so that it requires
-- 'Applicative' and not 'Monad' whenever possible (until #20540 is fixed).
(pure_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) pureAName
- let expr = noLocA (HsApp noExtField (noLocA ret) tup)
+ let expr = noLocA (genHsApps pure_name [tup])
return (expr, emptyFVs)
return ( ApplicativeArgMany
{ xarg_app_arg_many = noExtField
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -181,7 +181,7 @@ tcInferSigma inst (L loc rn_expr)
do { (fun@(rn_fun,fun_ctxt), rn_args) <- splitHsApps rn_expr
; do_ql <- wantQuickLook rn_fun
; (tc_fun, fun_sigma) <- tcInferAppHead fun
- ; (inst_args, app_res_sigma) <- tcInstFun do_ql inst (tc_fun, fun_ctxt) fun_sigma rn_args
+ ; (inst_args, app_res_sigma) <- tcInstFun do_ql inst (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args
; _ <- tcValArgs do_ql inst_args
; return app_res_sigma }
@@ -409,7 +409,7 @@ tcApp rn_expr exp_res_ty
; (inst_args, app_res_rho)
<- setQLInstLevel do_ql $ -- See (TCAPP1) and (TCAPP2) in
-- Note [tcApp: typechecking applications]
- tcInstFun do_ql True tc_head fun_sigma rn_args
+ tcInstFun do_ql True (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args
; case do_ql of
NoQL -> do { traceTc "tcApp:NoQL" (ppr rn_fun $$ ppr app_res_rho)
@@ -418,6 +418,7 @@ tcApp rn_expr exp_res_ty
-- See Note [Unify with expected type before typechecking arguments]
; res_wrap <- checkResultTy rn_expr tc_head inst_args
app_res_rho exp_res_ty
+
-- Step 4.2: typecheck the arguments
; tc_args <- tcValArgs NoQL inst_args
-- Step 4.3: wrap up
@@ -513,7 +514,7 @@ checkResultTy rn_expr (tc_fun, fun_ctxt) inst_args app_res_rho (Check res_ty)
-- Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr
perhaps_add_res_ty_ctxt thing_inside
| insideExpansion fun_ctxt
- = addHeadCtxt fun_ctxt thing_inside
+ = thing_inside
| otherwise
= addFunResCtxt tc_fun inst_args app_res_rho (mkCheckExpType res_ty) $
thing_inside
@@ -539,12 +540,7 @@ tcValArg do_ql (EValArg { ea_ctxt = ctxt
, ea_arg = larg@(L arg_loc arg)
, ea_arg_ty = sc_arg_ty })
= addArgCtxt ctxt larg $
- do { traceTc "tcValArg" $
- vcat [ ppr ctxt
- , text "arg type:" <+> ppr sc_arg_ty
- , text "arg:" <+> ppr larg ]
-
- -- Crucial step: expose QL results before checking exp_arg_ty
+ do { -- Crucial step: expose QL results before checking exp_arg_ty
-- So far as the paper is concerned, this step applies
-- the poly-substitution Theta, learned by QL, so that we
-- "see" the polymorphism in that argument type. E.g.
@@ -553,14 +549,21 @@ tcValArg do_ql (EValArg { ea_ctxt = ctxt
-- Then Theta = [p :-> forall a. a->a], and we want
-- to check 'e' with expected type (forall a. a->a)
-- See Note [Instantiation variables are short lived]
- ; Scaled mult exp_arg_ty <- case do_ql of
+ Scaled mult exp_arg_ty <- case do_ql of
DoQL -> liftZonkM $ zonkScaledTcType sc_arg_ty
NoQL -> return sc_arg_ty
+ ; traceTc "tcValArg {" $
+ vcat [ text "ctxt:" <+> ppr ctxt
+ , text "sigma_type" <+> ppr (mkCheckExpType exp_arg_ty)
+ , text "arg:" <+> ppr larg
+ ]
+
-- Now check the argument
; arg' <- tcScalingUsage mult $
tcPolyExpr arg (mkCheckExpType exp_arg_ty)
-
+ ; traceTc "tcValArg" $ vcat [ ppr arg'
+ , text "}" ]
; return (EValArg { ea_ctxt = ctxt
, ea_arg = L arg_loc arg'
, ea_arg_ty = noExtField }) }
@@ -640,26 +643,21 @@ tcInstFun :: QLFlag
-- in tcInferSigma, which is used only to implement :type
-- Otherwise we do eager instantiation; in Fig 5 of the paper
-- |-inst returns a rho-type
- -> (HsExpr GhcTc, AppCtxt)
+ -> (HsExpr GhcTc, HsExpr GhcRn, AppCtxt)
-> TcSigmaType -> [HsExprArg 'TcpRn]
-> TcM ( [HsExprArg 'TcpInst]
, TcSigmaType )
-- This crucial function implements the |-inst judgement in Fig 4, plus the
-- modification in Fig 5, of the QL paper:
-- "A quick look at impredicativity" (ICFP'20).
-tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
+tcInstFun do_ql inst_final (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args
= do { traceTc "tcInstFun" (vcat [ text "tc_fun" <+> ppr tc_fun
, text "fun_sigma" <+> ppr fun_sigma
- , text "fun_ctxt" <+> ppr fun_ctxt
, text "args:" <+> ppr rn_args
, text "do_ql" <+> ppr do_ql ])
; go 1 [] fun_sigma rn_args }
where
- fun_orig = case fun_ctxt of
- VAExpansion (OrigStmt{}) _ _ -> DoOrigin
- VAExpansion (OrigPat pat _) _ _ -> DoPatOrigin pat
- VAExpansion (OrigExpr e) _ _ -> exprCtOrigin e
- VACall e _ _ -> exprCtOrigin e
+ fun_orig = exprCtOrigin rn_fun
-- These are the type variables which must be instantiated to concrete
-- types. See Note [Representation-polymorphic Ids with no binding]
@@ -821,9 +819,7 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
-- Rule IARG from Fig 4 of the QL paper:
go1 pos acc fun_ty
(EValArg { ea_arg = arg, ea_ctxt = ctxt } : rest_args)
- = do { let herald = case fun_ctxt of
- VAExpansion (OrigStmt{}) _ _ -> ExpectedFunTySyntaxOp DoOrigin tc_fun
- _ -> ExpectedFunTyArg (HsExprTcThing tc_fun) (unLoc arg)
+ = do { let herald = ExpectedFunTyArg (HsExprTcThing tc_fun) (unLoc arg)
; (wrap, arg_ty, res_ty) <-
-- NB: matchActualFunTy does the rep-poly check.
-- For example, suppose we have f :: forall r (a::TYPE r). a -> Int
@@ -880,7 +876,7 @@ looks_like_type_arg _ = False
addArgCtxt :: AppCtxt -> LHsExpr GhcRn
-> TcM a -> TcM a
--- There are four cases:
+-- There are 3 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`)
@@ -889,42 +885,21 @@ 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
--- 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
+-- 3. We are in an expanded `do`-block statement
+-- Do nothing as we have already added the error
+-- context in GHC.Tc.Do.tcXExpr
-- 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
+ ; traceTc "addArgCtxt" (vcat [ text "generated:" <+> ppr in_generated_code
+ , text "arg: " <+> ppr arg
+ , text "arg_loc" <+> ppr arg_loc])
; case ctxt of
VACall fun arg_no _ | not in_generated_code
-> do setSrcSpanA arg_loc $
addErrCtxt (FunAppCtxt (FunAppCtxtExpr 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 _ (XStmtLR (ApplicativeStmt{}))) _) _ _
- -> thing_inside
- VAExpansion (OrigStmt (L loc stmt) flav) _ _
- -> setSrcSpanA loc $
- addStmtCtxt stmt flav $
- thing_inside
-
_ -> setSrcSpanA arg_loc $
addExprCtxt arg $ -- Auto-suppressed if arg_loc is generated
thing_inside }
@@ -1761,7 +1736,7 @@ quickLookArg1 ctxt larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho)
; do_ql <- wantQuickLook rn_fun
; ((inst_args, app_res_rho), wanted)
<- captureConstraints $
- tcInstFun do_ql True tc_head fun_sigma rn_args
+ tcInstFun do_ql True (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args
-- We must capture type-class and equality constraints here, but
-- not equality constraints. See (QLA6) in Note [Quick Look at
-- value arguments]
=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -45,58 +45,56 @@ import Data.List ((\\))
* *
************************************************************************
-}
-
-- | Expand the `do`-statments into expressions right after renaming
-- so that they can be typechecked.
-- See Note [Expanding HsDo with XXExprGhcRn] below for `HsDo` specific commentary
-- and Note [Handling overloaded and rebindable constructs] for high level commentary
expandDoStmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (HsExpr GhcRn)
-expandDoStmts doFlav stmts = unLoc <$> expand_do_stmts False doFlav stmts
+expandDoStmts doFlav stmts = expand_do_stmts doFlav stmts
-- | The main work horse for expanding do block statements into applications of binds and thens
-- See Note [Expanding HsDo with XXExprGhcRn]
-expand_do_stmts :: Bool -> HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn)
+expand_do_stmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (HsExpr GhcRn)
-expand_do_stmts _ ListComp _ =
+expand_do_stmts ListComp _ =
pprPanic "expand_do_stmts: impossible happened. ListComp" empty
-- handeled by `GHC.Tc.Gen.Match.tcLcStmt`
-expand_do_stmts _ _ [] = pprPanic "expand_do_stmts: impossible happened. Empty stmts" empty
-
-expand_do_stmts _ _ (stmt@(L _ (TransStmt {})):_) =
+expand_do_stmts _ (stmt@(L _ (TransStmt {})):_) =
pprPanic "expand_do_stmts: TransStmt" $ ppr stmt
-- handeled by `GHC.Tc.Gen.Match.tcLcStmt`
-expand_do_stmts _ _ (stmt@(L _ (ParStmt {})):_) =
+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 _ [] = pprPanic "expand_do_stmts: impossible happened. Empty stmts" empty
+
+expand_do_stmts flav [stmt@(L _loc (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 body
-
+ = return $ mkExpandedStmt stmt flav body
| SyntaxExprRn ret <- ret_expr
--
-- ------------------------------------------------
-- return e ~~> return e
-- to make T18324 work
= do let expansion = genHsApp ret (L body_loc body)
- return $ mkExpandedStmtAt addPop loc stmt flav expansion
+ return $ mkExpandedStmt stmt flav expansion
-expand_do_stmts addPop doFlavour (stmt@(L loc (LetStmt _ bs)) : lstmts) =
+expand_do_stmts 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 expansion
+ do expand_stmts_expr <- expand_do_stmts doFlavour lstmts
+ let expansion = genHsLet bs (genPopErrCtxtExpr expand_stmts_expr)
+ return $ mkExpandedStmt stmt doFlavour expansion
-expand_do_stmts addPop doFlavour (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
+expand_do_stmts doFlavour (stmt@(L _loc (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
@@ -105,29 +103,29 @@ expand_do_stmts addPop doFlavour (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
-- _ -> fail "Pattern match failure .."
-- -------------------------------------------------------
-- pat <- e ; stmts ~~> (>>=) e f
- = do expand_stmts <- expand_do_stmts True doFlavour lstmts
- failable_expr <- mk_failable_expr False doFlavour pat expand_stmts fail_op
+ = do expand_stmts_expr <- expand_do_stmts doFlavour lstmts
+ failable_expr <- mk_failable_expr doFlavour pat (genPopErrCtxtExpr expand_stmts_expr) fail_op
let expansion = genHsExpApps bind_op -- (>>=)
[ e
, failable_expr ]
- return $ mkExpandedStmtAt addPop loc stmt doFlavour expansion
+ return $ mkExpandedStmt stmt doFlavour 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 doFlavour (stmt@(L _loc (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'
-- ----------------------------------------------
-- e ; stmts ~~> (>>) e stmts'
- do expand_stmts_expr <- expand_do_stmts True doFlavour lstmts
+ do expand_stmts_expr <- expand_do_stmts doFlavour lstmts
let expansion = genHsExpApps then_op -- (>>)
- [ e
- , expand_stmts_expr ]
- return $ mkExpandedStmtAt addPop loc stmt doFlavour expansion
+ [ e
+ , genPopErrCtxtExpr $ expand_stmts_expr ]
+ return $ mkExpandedStmt stmt doFlavour expansion
-expand_do_stmts _ doFlavour
+expand_do_stmts doFlavour
((L loc (RecStmt { recS_stmts = L stmts_loc rec_stmts
, recS_later_ids = later_ids -- forward referenced local ids
, recS_rec_ids = local_ids -- ids referenced outside of the rec block
@@ -147,14 +145,14 @@ expand_do_stmts _ doFlavour
-- -> do { rec_stmts
-- ; return (local_only_ids ++ later_ids) } ))
-- (\ [ local_only_ids ++ later_ids ] -> stmts')
- do expand_stmts <- expand_do_stmts True doFlavour lstmts
+ do expand_stmts_expr <- expand_do_stmts doFlavour lstmts
-- NB: No need to wrap the expansion with an ExpandedStmt
-- as we want to flatten the rec block statements into its parent do block anyway
- return $ mkHsApps (wrapGenSpan bind_fun) -- (>>=)
- [ (wrapGenSpan mfix_fun) `mkHsApp` mfix_expr -- (mfix (do block))
- , genHsLamDoExp doFlavour [ mkBigLHsVarPatTup all_ids ] -- (\ x ->
- expand_stmts -- stmts')
- ]
+ return $ unLoc (mkHsApps (wrapGenSpan bind_fun) -- (>>=)
+ [ (wrapGenSpan mfix_fun) `mkHsApp` mfix_expr -- (mfix (do block))
+ , genHsLamDoExp doFlavour [ mkBigLHsVarPatTup all_ids ] -- (\ x ->
+ (wrapGenSpan expand_stmts_expr) -- stmts')
+ ])
where
local_only_ids = local_ids \\ later_ids -- get unique local rec ids;
-- local rec ids and later ids can overlap
@@ -175,7 +173,7 @@ expand_do_stmts _ doFlavour
-- NB: LazyPat because we do not want to eagerly evaluate the pattern
-- and potentially loop forever
-expand_do_stmts addPop doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join))): lstmts) =
+expand_do_stmts doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join))): lstmts) =
-- See Note [Applicative BodyStmt]
--
-- stmts ~~> stmts'
@@ -185,13 +183,13 @@ expand_do_stmts addPop doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join)
-- Very similar to HsToCore.Expr.dsDo
-- args are [(<$>, e1), (<*>, e2), .., ]
- do { xexpr <- expand_do_stmts False doFlavour lstmts
+ do { xexpr <- expand_do_stmts doFlavour lstmts
-- extracts pats and arg bodies (rhss) from args
; (pats_can_fail, rhss) <- unzip <$> mapM (do_arg . snd) args
-- add blocks for failable patterns
- ; body_with_fails <- foldrM match_args xexpr pats_can_fail
+ ; body_with_fails <- foldrM match_args (wrapGenSpan xexpr) pats_can_fail
-- builds (((body <$> e1) <*> e2) ...)
; let expand_ado_expr = foldl mk_apps body_with_fails (zip (map fst args) rhss)
@@ -205,7 +203,7 @@ expand_do_stmts addPop doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join)
, text "lstmts:" <+> ppr lstmts
, text "mb_join:" <+> ppr mb_join
, text "expansion:" <+> ppr final_expr])
- ; return final_expr
+ ; return $ unLoc final_expr
}
where
@@ -214,7 +212,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 rhs
+ do let xx_expr = mkExpandedStmtAt rhs_loc stmt doFlavour rhs
traceTc "do_arg" (text "OneArg" <+> vcat [ppr pat, ppr xx_expr])
return ((pat, mb_fail_op)
, xx_expr)
@@ -223,13 +221,14 @@ expand_do_stmts addPop doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join)
, final_expr = ret@(L ret_loc _)
, bv_pattern = pat
, stmt_context = ctxt }) =
- do { xx_expr <- (wrapGenSpan . unLoc) <$> (expand_do_stmts addPop ctxt $ stmts ++ [L ret_loc $ mkLastStmt ret])
- ; traceTc "do_arg" (text "ManyArg" <+> ppr addPop <+> vcat [ppr (stmts ++ [L ret_loc $ mkLastStmt ret]), text "--", ppr xx_expr])
+ do { xx_expr <- expand_do_stmts ctxt $ stmts ++ [L ret_loc $ mkLastStmt ret]
+ ; traceTc "do_arg" (text "ManyArg"
+ <+> vcat [ppr (stmts ++ [L ret_loc $ mkLastStmt ret]), text "--", ppr xx_expr])
; return ((pat, Nothing)
- , xx_expr) }
+ , wrapGenSpan xx_expr) }
- 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
+ match_args :: (LPat GhcRn, FailOperator GhcRn) -> LHsExpr GhcRn -> TcM (LHsExpr GhcRn)
+ match_args (pat, fail_op) body = mk_failable_expr doFlavour pat body fail_op
mk_apps :: LHsExpr GhcRn -> (SyntaxExprRn, LHsExpr GhcRn) -> LHsExpr GhcRn
mk_apps l_expr (op, r_expr) =
@@ -237,31 +236,28 @@ expand_do_stmts addPop doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join)
SyntaxExprRn op -> wrapGenSpan $ genHsExpApps op [ l_expr, r_expr ]
NoSyntaxExprRn -> pprPanic "expand_do_stmts applicative op:" (ppr op)
-expand_do_stmts _ _ stmts = pprPanic "expand_do_stmts: impossible happened" $ (ppr stmts)
+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 -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn)
-mk_failable_expr addPop doFlav lpat@(L loc pat) expr@(L exprloc _) fail_op =
+mk_failable_expr :: HsDoFlavour -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn)
+mk_failable_expr doFlav lpat expr@(L _exprloc _) fail_op =
do { is_strict <- xoptM LangExt.Strict
; hscEnv <- getTopEnv
; rdrEnv <- getGlobalRdrEnv
; comps <- getCompleteMatchesTcM
; let irrf_pat = isIrrefutableHsPat is_strict (irrefutableConLikeRn hscEnv rdrEnv comps) lpat
- ; traceTc "mk_failable_expr" (vcat [ text "pat:" <+> ppr pat
+ ; traceTc "mk_failable_expr" (vcat [ text "pat:" <+> ppr lpat
, 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] xexpr
- _ -> return $ genHsLamDoExp doFlav [lpat] xexpr
-
- else L loc <$> mk_fail_block doFlav lpat expr fail_op
+ then return $ genHsLamDoExp doFlav [lpat] expr
+ else wrapGenSpan <$> mk_fail_block doFlav lpat expr fail_op
}
--- makes the fail block with a given fail_op
+-- | Makes the fail block with a given fail_op
+-- mk_fail_block pat rhs fail builds
+-- \x. case x of {pat -> rhs; _ -> fail "Pattern match failure..."}
mk_fail_block :: HsDoFlavour
-> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (HsExpr GhcRn)
mk_fail_block doFlav pat@(L ploc _) e (Just (SyntaxExprRn fail_op)) =
@@ -273,12 +269,11 @@ mk_fail_block doFlav pat@(L ploc _) e (Just (SyntaxExprRn fail_op)) =
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) $
- L ploc (fail_op_expr dflags pat fail_op)
+ wrapGenSpan (fail_op_expr dflags pat fail_op)
fail_op_expr :: DynFlags -> LPat GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
fail_op_expr dflags pat fail_op
- = mkExpandedPatRn pat doFlav $
- genHsApp fail_op (mk_fail_msg_expr dflags pat)
+ = genHsApp fail_op (mk_fail_msg_expr dflags pat)
mk_fail_msg_expr :: DynFlags -> LPat GhcRn -> LHsExpr GhcRn
mk_fail_msg_expr dflags pat
@@ -341,10 +336,10 @@ They capture the essence of statement expansions as implemented in `expand_do_st
(2) DO【 p <- e; ss 】 = if p is irrefutable
then ‹ExpansionStmt (p <- e)›
- (>>=) s (‹PopExprCtxt›(\ p -> DO【 ss 】))
+ (>>=) s ((\ p -> ‹PopExprCtxt› DO【 ss 】))
else ‹ExpansionStmt (p <- e)›
- (>>=) s (‹PopExprCtxt›(\case p -> DO【 ss 】
- _ -> fail "pattern p failure"))
+ (>>=) s ((\case p -> ‹PopExprCtxt› DO【 ss 】
+ _ -> fail "pattern p failure"))
(3) DO【 let x = e; ss 】
= ‹ExpansionStmt (let x = e)› (let x = e in (‹PopErrCtxt›DO【 ss 】))
@@ -561,3 +556,23 @@ It stores the original statement (with location) and the expanded expression
We hence use a tag `GenReason` in `Ghc.Tc.Origin`. When typechecking a `HsLam` in `Tc.Gen.Expr.tcExpr`
the `match_ctxt` is set to a `StmtCtxt` if `GenOrigin` is a `DoExpansionOrigin`.
-}
+
+
+-- | Wrap a located expression with a `PopErrCtxt`
+mkPopErrCtxtExpr :: HsExpr GhcRn -> HsExpr GhcRn
+mkPopErrCtxtExpr a = XExpr (PopErrCtxt a)
+
+genPopErrCtxtExpr :: HsExpr GhcRn -> LHsExpr GhcRn
+genPopErrCtxtExpr a = wrapGenSpan $ mkPopErrCtxtExpr a
+
+-- | Build an expression using the extension constructor `XExpr`,
+-- and the two components of the expansion: original do stmt and
+-- expanded expression and associate it with a provided location
+mkExpandedStmtAt
+ :: SrcSpanAnnA
+ -> ExprLStmt GhcRn -- ^ source statement
+ -> HsDoFlavour -- ^ the flavour of the statement
+ -> HsExpr GhcRn -- ^ expanded expression
+ -> LHsExpr GhcRn -- ^ suitably wrapped located 'XXExprGhcRn'
+mkExpandedStmtAt loc oStmt flav eExpr
+ = L loc $ mkExpandedStmt oStmt flav eExpr
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -739,33 +739,19 @@ tcExpr (SectionR {}) ty = pprPanic "tcExpr:SectionR" (ppr ty)
tcXExpr :: XXExprGhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
-tcXExpr (PopErrCtxt (L loc e)) res_ty
+tcXExpr (PopErrCtxt e) res_ty
= popErrCtxt $ -- See Part 3 of Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do`
- setSrcSpanA loc $
tcExpr e res_ty
-tcXExpr xe@(ExpandedThingRn o e') res_ty
- | OrigStmt ls@(L loc s) flav <- o
- , HsLet x binds e <- e'
- = do { (binds', e') <- setSrcSpanA loc $
- addStmtCtxt s flav $
- tcLocalBinds binds $
- tcMonoExprNC e res_ty -- NB: Do not call tcMonoExpr here as it adds
- -- a duplicate error context
- ; return $ mkExpandedStmtTc ls flav (HsLet x binds' e')
- }
-
- | OrigStmt s@(L loc LastStmt{}) flav <- o
- = setSrcSpanA loc $
- addStmtCtxt (unLoc s) flav $
- mkExpandedStmtTc s flav <$> tcApp e' res_ty
-
- | OrigStmt ls@(L loc _) flav <- o
- = setSrcSpanA loc $
- mkExpandedStmtTc ls flav <$> tcApp (XExpr xe) res_ty
+tcXExpr (ExpandedThingRn o e) res_ty
+ = addThingCtxt o $
+ mkExpandedTc o <$> -- necessary for breakpoints
+ tcExpr e res_ty
+-- For record selection, etc
tcXExpr xe res_ty = tcApp (XExpr xe) res_ty
+
{-
************************************************************************
* *
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -28,7 +28,7 @@ module GHC.Tc.Gen.Head
, nonBidirectionalErr
, pprArgInst
- , addHeadCtxt, addExprCtxt, addStmtCtxt, addFunResCtxt ) where
+ , addHeadCtxt, addThingCtxt, addExprCtxt, addStmtCtxt, addFunResCtxt ) where
import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckPolyExprNC, tcPolyLExprSig )
import {-# SOURCE #-} GHC.Tc.Gen.Splice( getUntypedSpliceBody )
@@ -210,9 +210,6 @@ data EWrap = EPar AppCtxt
data AppCtxt
= VAExpansion
- HsThingRn
- SrcSpan
- SrcSpan
| VACall
(HsExpr GhcRn) Int -- In the third argument of function f
@@ -248,19 +245,19 @@ a second time.
-}
appCtxtLoc :: AppCtxt -> SrcSpan
-appCtxtLoc (VAExpansion _ l _) = l
+appCtxtLoc VAExpansion = generatedSrcSpan
appCtxtLoc (VACall _ _ l) = l
insideExpansion :: AppCtxt -> Bool
insideExpansion (VAExpansion {}) = True
-insideExpansion (VACall _ _ src) = isGeneratedSrcSpan src
+insideExpansion (VACall _ _ loc) = isGeneratedSrcSpan loc
instance Outputable QLFlag where
ppr DoQL = text "DoQL"
ppr NoQL = text "NoQL"
instance Outputable AppCtxt where
- ppr (VAExpansion e l _) = text "VAExpansion" <+> ppr e <+> ppr l
+ ppr VAExpansion = text "VAExpansion"
ppr (VACall f n l) = text "VACall" <+> int n <+> ppr f <+> ppr l
type family XPass (p :: TcPass) where
@@ -283,6 +280,7 @@ addArgWrap wrap args
| isIdHsWrapper wrap = args
| otherwise = EWrap (EHsWrap wrap) : args
+
splitHsApps :: HsExpr GhcRn
-> TcM ( (HsExpr GhcRn, AppCtxt) -- Head
, [HsExprArg 'TcpRn]) -- Args
@@ -297,14 +295,14 @@ splitHsApps e = go e (top_ctxt 0 e) []
-- Always returns VACall fun n_val_args noSrcSpan
-- to initialise the argument splitting in 'go'
-- See Note [AppCtxt]
- top_ctxt n (HsPar _ fun) = top_lctxt n fun
+
+ top_ctxt n (HsPar _ fun) = top_lctxt n fun
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) _))
- = VACall fun n noSrcSpan
top_ctxt n other_fun = VACall other_fun n noSrcSpan
+ top_lctxt :: Int -> LHsExpr GhcRn -> AppCtxt
top_lctxt n (L _ fun) = top_ctxt n fun
go :: HsExpr GhcRn -> AppCtxt -> [HsExprArg 'TcpRn]
@@ -325,11 +323,6 @@ splitHsApps e = go e (top_ctxt 0 e) []
HsUntypedSpliceExpr _ (L l _) -> set l ctxt -- l :: SrcAnn AnnListItem
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))
- (EWrap (EExpand o) : args)
-
-- See Note [Desugar OpApp in the typechecker]
go e@(OpApp _ arg1 (L l op) arg2) _ args
= pure ( (op, VACall op 0 (locA l))
@@ -344,11 +337,11 @@ splitHsApps e = go e (top_ctxt 0 e) []
set :: EpAnn ann -> AppCtxt -> AppCtxt
set l (VACall f n _) = VACall f n (locA l)
- set l (VAExpansion orig ol _) = VAExpansion orig ol (locA l)
+ set _ ctx = ctx
dec :: EpAnn ann -> AppCtxt -> AppCtxt
dec l (VACall f n _) = VACall f (n-1) (locA l)
- dec l (VAExpansion orig ol _) = VAExpansion orig ol (locA l)
+ dec _ ctx = ctx
-- | Rebuild an application: takes a type-checked application head
-- expression together with arguments in the form of typechecked 'HsExprArg's
@@ -377,15 +370,12 @@ rebuildHsApps (fun, ctxt) (arg : args)
EWrap (EExpand orig)
| OrigExpr oe <- orig
-> rebuildHsApps (mkExpandedExprTc oe fun, ctxt) args
- | otherwise
- -> rebuildHsApps (fun, ctxt) args
+ | OrigStmt stmt flav <- orig
+ -> rebuildHsApps (mkExpandedStmtTc stmt flav fun, ctxt) args
EWrap (EHsWrap wrap)
-> rebuildHsApps (mkHsWrap wrap fun, ctxt) args
where
- lfun = L (noAnnSrcSpan $ appCtxtLoc' ctxt) fun
- appCtxtLoc' (VAExpansion _ _ l) = l
- appCtxtLoc' v = appCtxtLoc v
-
+ lfun = L (noAnnSrcSpan $ appCtxtLoc ctxt) fun
isHsValArg :: HsExprArg id -> Bool
isHsValArg (EValArg {}) = True
@@ -556,19 +546,7 @@ 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
- | not (isGoodSrcSpan fun_loc) -- noSrcSpan => no arguments
- = thing_inside -- => context is already set
- | otherwise
- = setSrcSpan fun_loc $
- do case fun_ctxt of
- VAExpansion (OrigExpr orig) _ _
- -> addExprCtxt orig thing_inside
- _ -> thing_inside
+addHeadCtxt fun_ctxt thing_inside = setSrcSpan fun_loc thing_inside
where
fun_loc = appCtxtLoc fun_ctxt
@@ -1247,16 +1225,25 @@ mis-match in the number of value arguments.
* *
********************************************************************* -}
-addStmtCtxt :: ExprStmt GhcRn -> TcRn a -> TcRn a
-addStmtCtxt stmt =
- addErrCtxt (StmtErrCtxt (HsDoStmt (DoExpr Nothing)) stmt)
+
+addStmtCtxt :: ExprStmt GhcRn -> HsDoFlavour -> TcRn a -> TcRn a
+addStmtCtxt stmt flav =
+ addErrCtxt (StmtErrCtxt (HsDoStmt flav) stmt)
+
+addThingCtxt :: HsThingRn -> TcRn a -> TcRn a
+addThingCtxt (OrigStmt (L loc stmt) flav) thing_inside = do
+ setSrcSpanA loc $
+ addStmtCtxt stmt flav $
+ setInGeneratedCode
+ thing_inside
+addThingCtxt (OrigExpr e) thing_inside = addExprCtxt e thing_inside
addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt e thing_inside
= case e of
- HsUnboundVar {} -> thing_inside
- _ -> addErrCtxt (ExprCtxt e) thing_inside
- -- The HsUnboundVar special case addresses situations like
+ -- The HsUnboundVar special case addresses situations like
-- f x = _
-- when we don't want to say "In the expression: _",
-- because it is mentioned in the error message itself
+ HsUnboundVar {} -> thing_inside
+ _ -> addErrCtxt (ExprCtxt e) thing_inside
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -84,7 +84,7 @@ import GHC.Types.Basic( VisArity, isDoExpansionGenerated )
import qualified GHC.Data.List.NonEmpty as NE
import Control.Monad
-import qualified Data.List.NonEmpty as NE
+import Data.List.NonEmpty (NonEmpty(..), toList)
import Data.Maybe (mapMaybe)
import qualified GHC.LanguageExtensions as LangExt
@@ -350,12 +350,14 @@ tcDoStmts ListComp (L l stmts) res_ty
tcDoStmts doExpr@(DoExpr _) ss@(L _ stmts) res_ty
= do { expanded_expr <- expandDoStmts doExpr stmts -- Do expansion on the fly
- ; mkExpandedExprTc (HsDo noExtField doExpr ss) <$> tcExpr expanded_expr res_ty
+ ; let orig = HsDo noExtField doExpr ss
+ ; mkExpandedExprTc orig <$> tcExpr expanded_expr res_ty
}
tcDoStmts mDoExpr@(MDoExpr _) ss@(L _ stmts) res_ty
= do { expanded_expr <- expandDoStmts mDoExpr stmts -- Do expansion on the fly
- ; mkExpandedExprTc (HsDo noExtField mDoExpr ss) <$> tcExpr expanded_expr res_ty }
+ ; let orig = HsDo noExtField mDoExpr ss
+ ; mkExpandedExprTc orig <$> tcExpr expanded_expr res_ty }
tcDoStmts MonadComp (L l stmts) res_ty
= do { stmts' <- tcStmts (HsDoStmt MonadComp) tcMcStmt stmts res_ty
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -757,7 +757,6 @@ exprCtOrigin (HsQual {}) = Shouldn'tHappenOrigin "constraint context" -
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 (PopErrCtxt {})) = Shouldn'tHappenOrigin "PopErrCtxt"
exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel (foExt f)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0dbe4b10a497adf3592f4be034bf7cb52bcf2110...1229a9f18eb0805ca16fcf72cc75666d845e6805
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0dbe4b10a497adf3592f4be034bf7cb52bcf2110...1229a9f18eb0805ca16fcf72cc75666d845e6805
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/20250303/ac85c067/attachment-0001.html>
More information about the ghc-commits
mailing list