Apoorv Ingle pushed to branch wip/ani/kill-SrcCodeOrigin at Glasgow Haskell Compiler / GHC Commits: ec201fd2 by Apoorv Ingle at 2026-03-01T14:24:33-06:00 ErrCtxtMsg to CtOrigin - - - - - 10 changed files: - compiler/GHC/Hs/Instances.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Do.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/Tc/Types/LclEnv.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/Tc/Utils/Monad.hs Changes: ===================================== compiler/GHC/Hs/Instances.hs ===================================== @@ -640,11 +640,12 @@ deriving instance Eq (IE GhcRn) deriving instance Eq (IE GhcTc) -- --------------------------------------------------------------------- - +-- TODO: I think we still need instances for StmtCtxt, ExprCtxt and PatCtxt ctors of ErrCtxtMsg instance Data ErrCtxtMsg where gunfold _ _ _ = error "no gunfold for ErrCtxtMsg" gfoldl _ _ _ = error "no goldl for ErrCtxtMsg" - + toConstr = error "no toConstr for ErrCtxtMsg" + dataTypeOf = error "no dataTypeOf for ErrCtxtMsg" deriving instance Data XXExprGhcRn ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -20,6 +20,7 @@ import GHC.Hs import GHC.Tc.Gen.Head import GHC.Tc.Errors.Types +import GHC.Tc.Errors.Ppr import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Unify import GHC.Tc.Utils.Instantiate @@ -275,7 +276,7 @@ tcApp works like this: 2. Use tcInferAppHead to infer the type of the function, as an (uninstantiated) TcSigmaType There are special cases for - HsVar, HsRecSel, and ExprWithTySig + HsVar, HsRecSel, and ExprWithTySig and XExpr Otherwise, delegate back to tcExpr, which infers an (instantiated) TcRhoType @@ -2050,6 +2051,7 @@ mk_origin fun_lspan_arg rn_fun_arg rn_fun = return $ exprCtOrigin rn_fun_arg | otherwise = do { code_orig <- getSrcCodeOrigin + ; traceTc "mk_origin" (case (pprErrCtxtMsg <$> code_orig) of { Just e -> e; _ -> text "Nothing"}) ; return $ srcCodeOriginCtOrigin rn_fun code_orig } ===================================== compiler/GHC/Tc/Gen/Do.hs ===================================== @@ -213,7 +213,7 @@ mk_fail_block doFlav pat stmt e (Just (SyntaxExprRn fail_op)) = fail_op_expr :: DynFlags -> LPat GhcRn -> HsExpr GhcRn -> LHsExpr GhcRn fail_op_expr dflags pat@(L pat_lspan _) fail_op - = L pat_lspan $ mkExpandedPatRn doFlav (unLoc pat) stmt $ genHsApp fail_op (mk_fail_msg_expr dflags pat) + = L pat_lspan $ mkExpandedPatRn doFlav pat stmt $ genHsApp fail_op (mk_fail_msg_expr dflags pat) mk_fail_msg_expr :: DynFlags -> LPat GhcRn -> LHsExpr GhcRn mk_fail_msg_expr dflags pat @@ -481,7 +481,7 @@ It stores the original statement (with location) and the expanded expression -} -mkExpandedPatRn :: HsDoFlavour -> Pat GhcRn -> ExprLStmt GhcRn -> HsExpr GhcRn -> HsExpr GhcRn +mkExpandedPatRn :: HsDoFlavour -> LPat GhcRn -> ExprLStmt GhcRn -> HsExpr GhcRn -> HsExpr GhcRn mkExpandedPatRn flav pat stmt e = XExpr $ ExpandedThingRn { xrn_orig = StmtErrCtxtPat (HsDoStmt flav) stmt pat , xrn_expanded = e} ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -430,6 +430,7 @@ tcInferAppHead :: (HsExpr GhcRn, SrcSpan) -- * A bare identifier (just look it up) -- This case also covers a record selector HsRecSel -- * An expression with a type signature (e :: ty) +-- * An XExpr where 'f' is actually an expanded out expression -- See Note [Application chains and heads] in GHC.Tc.Gen.App -- -- Note that [] and (,,) are both HsVar: @@ -452,6 +453,8 @@ tcInferAppHead_maybe :: HsExpr GhcRn -> TcM (Maybe (HsExpr GhcTc, DeepSubsumptionFlag, TcSigmaType)) -- See Note [Application chains and heads] in GHC.Tc.Gen.App -- Returns Nothing for a complicated head +-- XExpr's although complicated needs to be looked through, useful for QL things when +-- the argument is an XExpr tcInferAppHead_maybe fun = case fun of HsVar _ nm -> Just <$> with_get_ds (tcInferId nm) ExprWithTySig _ e hs_ty -> Just <$> with_get_ds (tcExprWithSig e hs_ty) ===================================== compiler/GHC/Tc/Types.hs ===================================== @@ -1,5 +1,4 @@ {-# LANGUAGE PatternSynonyms #-} - {- (c) The University of Glasgow 2006-2012 (c) The GRASP Project, Glasgow University, 1992-2002 ===================================== compiler/GHC/Tc/Types/ErrCtxt.hs ===================================== @@ -340,7 +340,7 @@ data ErrCtxtMsg | DoStmtErrCtxt !HsStmtContextRn !(ExprLStmt GhcRn) -- | In patten of the do statement. (c.f. MonadFailErrors) - | StmtErrCtxtPat !HsStmtContextRn !(ExprLStmt GhcRn) (Pat GhcRn) + | StmtErrCtxtPat !HsStmtContextRn !(ExprLStmt GhcRn) (LPat GhcRn) -- | In an rebindable syntax expression. | SyntaxNameCtxt !(HsExpr GhcRn) !CtOrigin !TcType !SrcSpan ===================================== compiler/GHC/Tc/Types/LclEnv.hs ===================================== @@ -211,11 +211,12 @@ setLclEnvSrcCodeOrigin ec = modifyLclCtxt (setLclCtxtSrcCodeOrigin ec) -- See Note [ErrCtxtStack Manipulation] setLclCtxtSrcCodeOrigin :: ErrCtxt -> TcLclCtxt -> TcLclCtxt setLclCtxtSrcCodeOrigin ec lclCtxt - | ecs@(MkErrCtxt ExpansionCodeCtxt _ : _) <- tcl_err_ctxt lclCtxt - , MkErrCtxt ExpansionCodeCtxt ExprCtxt{} <- ec - = lclCtxt { tcl_err_ctxt = ec : ecs } - | MkErrCtxt ExpansionCodeCtxt _ : ecs <- tcl_err_ctxt lclCtxt - , MkErrCtxt ExpansionCodeCtxt _ <- ec + -- | ecs@(MkErrCtxt ExpansionCodeCtxt _ : _) <- tcl_err_ctxt lclCtxt + -- , MkErrCtxt ExpansionCodeCtxt ExprCtxt{} <- ec + -- = lclCtxt { tcl_err_ctxt = ec : ecs } + -- never stack 2 statement error contexts on top of each other + | MkErrCtxt _ DoStmtErrCtxt{} : ecs <- tcl_err_ctxt lclCtxt + , MkErrCtxt _ DoStmtErrCtxt{} <- ec = lclCtxt { tcl_err_ctxt = ec : ecs } | otherwise = lclCtxt { tcl_err_ctxt = ec : tcl_err_ctxt lclCtxt } ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -455,7 +455,7 @@ data CtOrigin -- `ty1` to `ty2`. | DefaultOrigin -- Typechecking a default decl - | DoStmtOrigin -- Arising from a do expression + | DoStmtOrigin -- Arising from a do statement | DoPatOrigin (LPat GhcRn) -- Arising from a failable pattern in -- a do expression | MCompOrigin -- Arising from a monad comprehension @@ -690,12 +690,22 @@ exprCtOrigin e@(HsIf {}) = ExpansionOrigin (ExprCtxt e) exprCtOrigin e@(HsProjection _ _) = ExpansionOrigin (ExprCtxt e) exprCtOrigin e@(RecordUpd{}) = ExpansionOrigin (ExprCtxt e) exprCtOrigin e@(HsGetField{}) = ExpansionOrigin (ExprCtxt e) -exprCtOrigin (XExpr (ExpandedThingRn o _)) = ExpansionOrigin o +exprCtOrigin (XExpr (ExpandedThingRn o _)) = errCtxtCtOrigin o exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel $ L (getLoc $ foLabel f) (foExt f) srcCodeOriginCtOrigin :: HsExpr GhcRn -> Maybe ErrCtxtMsg -> CtOrigin srcCodeOriginCtOrigin e Nothing = exprCtOrigin e -srcCodeOriginCtOrigin _ (Just o) = ExpansionOrigin o +srcCodeOriginCtOrigin _ (Just o) = errCtxtCtOrigin o + + +errCtxtCtOrigin :: ErrCtxtMsg -> CtOrigin +errCtxtCtOrigin (ExprCtxt e) = exprCtOrigin e +errCtxtCtOrigin (FunAppCtxt (FunAppCtxtExpr _ e) _) = exprCtOrigin e +errCtxtCtOrigin (StmtErrCtxt{}) = DoStmtOrigin +errCtxtCtOrigin (DoStmtErrCtxt{}) = DoStmtOrigin +errCtxtCtOrigin (StmtErrCtxtPat _ _ p) = DoPatOrigin p +errCtxtCtOrigin _ = Shouldn'tHappenOrigin "errCtxtCtOrigin" + -- | Extract a suitable CtOrigin from a MatchGroup matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin @@ -731,6 +741,8 @@ pprCtOrigin (ExpansionOrigin o) what = case o of StmtErrCtxt{} -> text "a do statement" + DoStmtErrCtxt{} -> + text "a do statement" StmtErrCtxtPat _ _ p -> text "a do statement" $$ text "with the failable pattern" <+> quotes (ppr p) @@ -744,6 +756,7 @@ pprCtOrigin (ExpansionOrigin o) ExprCtxt (HsProjection _ p) -> text "the record selector" <+> quotes (ppr ((FieldLabelStrings $ fmap noLocA p))) ExprCtxt e -> text "the expression" <+> (ppr e) + RecordUpdCtxt{} -> text "a record update" _ -> text "shouldn't happen ExpansionOrigin pprCtOrigin" pprCtOrigin (GivenSCOrigin sk d blk) ===================================== compiler/GHC/Tc/Utils/Instantiate.hs ===================================== @@ -52,7 +52,6 @@ import GHC.Core.FamInstEnv import GHC.Core ( isOrphan ) -- For the Coercion constructor import GHC.Core.Type import GHC.Core.TyCo.Ppr ( debugPprType ) -import GHC.Core.TyCo.Tidy ( tidyType ) import GHC.Core.Class( Class ) import GHC.Core.Coercion.Axiom ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -1330,27 +1330,28 @@ addLExprCtxt lspan e thing_inside = setSrcSpan lspan $ add_expr_ctxt e thing_inside | otherwise -- no op in generated code = thing_inside + where + add_expr_ctxt :: HsExpr GhcRn -> TcRn a -> TcRn a + add_expr_ctxt e thing_inside + = case e of + -- The HsHole 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 + HsHole{} -> thing_inside + + -- There is a special case for expressions with signatures to avoid having too verbose + -- error context. So here we flip the ErrCtxt state to expanded if the expression is expanded. + -- c.f. RecordDotSyntaxFail9 + ExprWithTySig _ (L _ e') _ + | XExpr (ExpandedThingRn o _) <- e' -> addExpansionErrCtxt o thing_inside + + -- Flip error ctxt into expansion mode + XExpr (ExpandedThingRn o _) -> addExpansionErrCtxt o thing_inside + + _ -> addErrCtxt (ExprCtxt e) thing_inside + --- | !Caution!: Users should not call add_expr_ctxt, they ought to use addLExprCtxt -add_expr_ctxt :: HsExpr GhcRn -> TcRn a -> TcRn a -add_expr_ctxt e thing_inside - = case e of - HsHole{} -> thing_inside - -- The HsHole 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 - - ExprWithTySig _ (L _ e') _ - | XExpr (ExpandedThingRn o _) <- e' -> addExpansionErrCtxt o thing_inside - -- There is a special case for expressions with signatures to avoid having too verbose - -- error context. So here we flip the ErrCtxt state to expanded if the expression is expanded. - -- c.f. RecordDotSyntaxFail9 - - XExpr (ExpandedThingRn o _) -> addExpansionErrCtxt o thing_inside - -- Flip error ctxt into expansion mode - - _ -> addErrCtxt (ExprCtxt e) thing_inside getErrCtxt :: TcM [ErrCtxt] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ec201fd2f14a2ff83fcca19c2e51ee96... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ec201fd2f14a2ff83fcca19c2e51ee96... You're receiving this email because of your account on gitlab.haskell.org.