Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: 6898bc9d by Apoorv Ingle at 2025-07-20T19:58:03-05:00 more changes to printing origin - - - - - 2 changed files: - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Types/Origin.hs Changes: ===================================== compiler/GHC/Tc/Instance/Class.hs ===================================== @@ -22,7 +22,7 @@ import GHC.Tc.Instance.Typeable import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Evidence import GHC.Tc.Types.CtLoc -import GHC.Tc.Types.Origin ( InstanceWhat (..), SafeOverlapping, CtOrigin(GetFieldOrigin) ) +import GHC.Tc.Types.Origin ( InstanceWhat (..), SafeOverlapping, CtOrigin(ExpansionOrigin) ) import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst, FamInstEnvs ) import GHC.Rename.Env( addUsedGRE, addUsedDataCons, DeprecationWarnings (..) ) @@ -61,7 +61,7 @@ import GHC.Data.Maybe ( expectJust ) import GHC.Unit.Module.Warnings -import GHC.Hs.Extension +import GHC.Hs import Language.Haskell.Syntax.Basic (FieldLabelString(..)) import GHC.Types.Id.Info @@ -1327,7 +1327,7 @@ warnIncompleteRecSel dflags sel_id ct_loc -- GHC.Tc.Gen.App.tcInstFun arranges that the CtOrigin of (r.x) is GetFieldOrigin, -- despite the expansion to (getField @"x" r) - isGetFieldOrigin (GetFieldOrigin {}) = True + isGetFieldOrigin (ExpansionOrigin (OrigExpr (HsGetField {}))) = True isGetFieldOrigin _ = False lookupHasFieldLabel ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -783,10 +783,7 @@ lexprCtOrigin (L _ e) = exprCtOrigin e exprCtOrigin :: HsExpr GhcRn -> CtOrigin exprCtOrigin (HsVar _ (L _ (WithUserRdr _ name))) = OccurrenceOf name -exprCtOrigin e@(HsGetField _ _ (L _ _)) = ExpansionOrigin (OrigExpr e) - -- GetFieldOrigin (field_label $ unLoc $ dfoLabel f) exprCtOrigin (HsOverLabel _ l) = OverLabelOrigin l -exprCtOrigin (ExplicitList {}) = ListOrigin exprCtOrigin (HsIPVar _ ip) = IPOccOrigin ip exprCtOrigin (HsOverLit _ lit) = LiteralOrigin lit exprCtOrigin (HsLit {}) = Shouldn'tHappenOrigin "concrete literal" @@ -796,18 +793,15 @@ exprCtOrigin (HsAppType _ e1 _) = lexprCtOrigin e1 exprCtOrigin (OpApp _ _ op _) = lexprCtOrigin op exprCtOrigin (NegApp _ e _) = lexprCtOrigin e exprCtOrigin (HsPar _ e) = lexprCtOrigin e -exprCtOrigin e@(HsProjection _ _) = ExpansionOrigin (OrigExpr e) exprCtOrigin (SectionL _ _ _) = SectionOrigin exprCtOrigin (SectionR _ _ _) = SectionOrigin exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple" exprCtOrigin ExplicitSum{} = Shouldn'tHappenOrigin "explicit sum" exprCtOrigin (HsCase _ _ matches) = matchesCtOrigin matches -exprCtOrigin (HsIf {}) = IfThenElseOrigin exprCtOrigin (HsMultiIf _ rhs) = lGRHSCtOrigin rhs exprCtOrigin (HsLet _ _ e) = lexprCtOrigin e exprCtOrigin (HsDo {}) = DoStmtOrigin exprCtOrigin (RecordCon {}) = Shouldn'tHappenOrigin "record construction" -exprCtOrigin (RecordUpd{}) = RecordUpdOrigin exprCtOrigin (ExprWithTySig {}) = ExprSigOrigin exprCtOrigin (ArithSeq {}) = Shouldn'tHappenOrigin "arithmetic sequence" exprCtOrigin (HsPragE _ _ e) = lexprCtOrigin e @@ -822,6 +816,12 @@ exprCtOrigin (HsHole _) = Shouldn'tHappenOrigin "hole 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 e@(HsProjection _ _) = ExpansionOrigin (OrigExpr e) +exprCtOrigin e@(ExplicitList {}) = ExpansionOrigin (OrigExpr e) +exprCtOrigin e@(HsIf {}) = ExpansionOrigin (OrigExpr e) +exprCtOrigin e@(RecordUpd{}) = ExpansionOrigin (OrigExpr e) +exprCtOrigin e@(HsGetField{}) = ExpansionOrigin (OrigExpr e) + -- GetFieldOrigin (field_label $ unLoc $ dfoLabel f) exprCtOrigin (XExpr (ExpandedThingRn o _)) = ExpansionOrigin o exprCtOrigin (XExpr (PopErrCtxt e)) = exprCtOrigin e exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel (foExt f) @@ -869,7 +869,9 @@ pprCtOrigin (ExpansionOrigin o) hsep [text "selecting the field", quotes (ppr f)] OrigExpr (HsOverLabel _ l) -> hsep [text "the overloaded label" ,quotes (char '#' <> ppr l)] - OrigExpr e@(RecordUpd{}) -> hsep [text "a record update" <+> quotes (ppr e) ] + OrigExpr (RecordUpd{}) -> hsep [text "a record update"] + OrigExpr (ExplicitList{}) -> text "an overloaded list" + OrigExpr (HsIf{}) -> text "an if-then-else expression" OrigExpr e -> text "the expression" <+> (ppr e) pprCtOrigin (GivenSCOrigin sk d blk) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6898bc9de8d412f2b7d2b75a7c54eb25... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6898bc9de8d412f2b7d2b75a7c54eb25... You're receiving this email because of your account on gitlab.haskell.org.