Apoorv Ingle pushed to branch wip/ani/kill-SrcCodeOrigin at Glasgow Haskell Compiler / GHC Commits: ef338e58 by Apoorv Ingle at 2026-02-08T22:47:48-06:00 trying to remove SrcCodeOrigin. Cannot Derive Data instance for SrcCodeOrigin - - - - - 18 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Expr.hs-boot - compiler/GHC/Hs/Instances.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Do.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/Tc/Types/LclEnv.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Types/Origin.hs-boot - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/TcType.hs-boot - + compiler/GHC/Types/Error.hs-boot - + compiler/GHC/Unit/State.hs-boot - compiler/GHC/Utils/Logger.hs Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -34,6 +34,7 @@ import GHC.Parser.Annotation -- others: import GHC.Tc.Types.Evidence +import GHC.Tc.Types.ErrCtxt import GHC.Types.Id.Info ( RecSelParent ) import GHC.Types.Name import GHC.Types.Name.Reader @@ -658,16 +659,8 @@ 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 SrcCodeOrigin - = OrigExpr (HsExpr GhcRn) -- ^ The source, user written, expression - | OrigStmt (ExprLStmt GhcRn) HsDoFlavour -- ^ which kind of do-block did this statement come from - | OrigPat (ExprLStmt GhcRn) (Pat GhcRn) -- ^ Used for failable patterns that trigger MonadFail constraints - data XXExprGhcRn - = ExpandedThingRn { xrn_orig :: SrcCodeOrigin -- The original source thing to be used for error messages + = ExpandedThingRn { xrn_orig :: ErrCtxtMsg -- The original source thing context to be used for error messages , xrn_expanded :: HsExpr GhcRn -- The compiler generated, expanded thing } @@ -679,21 +672,21 @@ data XXExprGhcRn -- and the two components of the expansion: original expression and -- expanded expressions. mkExpandedExpr - :: HsExpr GhcRn -- ^ source expression + :: HsExpr GhcRn -- ^ source expression context -> HsExpr GhcRn -- ^ expanded expression -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn' -mkExpandedExpr oExpr eExpr = XExpr (ExpandedThingRn { xrn_orig = OrigExpr oExpr +mkExpandedExpr oExpr eExpr = XExpr (ExpandedThingRn { xrn_orig = ExprCtxt oExpr , xrn_expanded = eExpr }) -- | Build an expression using the extension constructor `XExpr`, -- and the two components of the expansion: original do stmt and -- expanded expression mkExpandedStmt - :: ExprLStmt GhcRn -- ^ source statement - -> HsDoFlavour -- ^ source statement do flavour + :: ExprLStmt GhcRn -- ^ source statement context + -> HsDoFlavour -- ^ source statements do flavour -> HsExpr GhcRn -- ^ expanded expression -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn' -mkExpandedStmt oStmt flav eExpr = XExpr (ExpandedThingRn { xrn_orig = OrigStmt oStmt flav +mkExpandedStmt oStmt flav eExpr = XExpr (ExpandedThingRn { xrn_orig = StmtErrCtxt (HsDoStmt flav) oStmt , xrn_expanded = eExpr }) data XXExprGhcTc @@ -702,7 +695,7 @@ data XXExprGhcTc | ExpandedThingTc -- See Note [Rebindable syntax and XXExprGhcRn] -- See Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do` - { xtc_orig :: SrcCodeOrigin -- The original user written thing + { xtc_orig :: ErrCtxtMsg -- The original user written thing , xtc_expanded :: HsExpr GhcTc } -- The expanded typechecked expression | ConLikeTc @@ -736,10 +729,10 @@ mkExpandedExprTc :: HsExpr GhcRn -- ^ source expression -> HsExpr GhcTc -- ^ expanded typechecked expression -> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcRn' -mkExpandedExprTc oExpr eExpr = mkExpandedTc (OrigExpr oExpr) eExpr +mkExpandedExprTc oExpr eExpr = mkExpandedTc (ExprCtxt oExpr) eExpr mkExpandedTc - :: SrcCodeOrigin -- ^ source, user written do statement/expression + :: ErrCtxtMsg -- ^ source, user written do statement/expression -> HsExpr GhcTc -- ^ expanded typechecked expression -> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcRn' mkExpandedTc o e = XExpr (ExpandedThingTc o e) @@ -1060,24 +1053,32 @@ ppr_expr (XExpr x) = case ghcPass @p of GhcRn -> ppr x GhcTc -> ppr x -instance Outputable SrcCodeOrigin where - ppr thing - = case thing of - OrigExpr x -> ppr_builder "<OrigExpr>:" x - OrigStmt x _ -> ppr_builder "<OrigStmt>:" x - OrigPat _ x -> ppr_builder "<OrigPat>:" 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 (HsRecSelRn f) = pprPrefixOcc f + ppr (ExpandedThingRn o e) = ifPprDebug (braces $ vcat [pprCtxt o, text ";;" , ppr e]) (pprCtxt o) + where + ppr_builder prefix x = ifPprDebug (braces (text prefix <+> parens x)) x + pprCtxt :: ErrCtxtMsg -> SDoc + pprCtxt (ExprCtxt e) = ppr_builder "<OrigExpr>:" (ppr e) + pprCtxt (StmtErrCtxt _ stmt) = ppr_builder "<OrigStmt>:" (ppr stmt) + pprCtxt (StmtErrCtxtPat _ _ pat) = ppr_builder "<OrigPat>:" (ppr pat) + pprCtxt _ = empty instance Outputable XXExprGhcTc where ppr (WrapExpr co_fn e) = pprHsWrapper co_fn (\_parens -> pprExpr e) ppr (ExpandedThingTc o e) - = ifPprDebug (braces $ vcat [ppr o, ppr e]) (ppr o) + = ifPprDebug (braces $ vcat [pprCtxt o, ppr e]) (pprCtxt o) + + where + ppr_builder prefix x = ifPprDebug (braces (text prefix <+> parens x)) x + pprCtxt :: ErrCtxtMsg -> SDoc + pprCtxt (ExprCtxt e) = ppr_builder "<OrigExpr>:" (ppr e) + pprCtxt (StmtErrCtxt _ stmt) = ppr_builder "<OrigStmt>:" (ppr stmt) + pprCtxt (StmtErrCtxtPat _ _ pat) = ppr_builder "<OrigPat>:" (ppr pat) + pprCtxt _ = empty + -- e is the expanded expression, we print the original -- expression (HsExpr GhcRn), not the -- expanded typechecked one (HsExpr GhcTc), @@ -1125,8 +1126,8 @@ ppr_infix_expr_tc (HsTick {}) = Nothing ppr_infix_expr_tc (HsBinTick {}) = Nothing ppr_infix_expr_tc (HsRecSelTc f) = Just (pprInfixOcc f) -ppr_infix_hs_expansion :: SrcCodeOrigin -> Maybe SDoc -ppr_infix_hs_expansion (OrigExpr e) = ppr_infix_expr e +ppr_infix_hs_expansion :: ErrCtxtMsg -> Maybe SDoc +ppr_infix_hs_expansion (ExprCtxt e) = ppr_infix_expr e ppr_infix_hs_expansion _ = Nothing pprDebugParendExpr :: (OutputableBndrId p) @@ -1216,8 +1217,8 @@ hsExprNeedsParens prec = go go_x_rn (ExpandedThingRn thing _ ) = hsExpandedNeedsParens thing go_x_rn (HsRecSelRn{}) = False - hsExpandedNeedsParens :: SrcCodeOrigin -> Bool - hsExpandedNeedsParens (OrigExpr e) = hsExprNeedsParens prec e + hsExpandedNeedsParens :: ErrCtxtMsg -> Bool + hsExpandedNeedsParens (ExprCtxt e) = hsExprNeedsParens prec e hsExpandedNeedsParens _ = False -- | Parenthesize an expression without token information @@ -1268,8 +1269,8 @@ isAtomicHsExpr (XExpr x) go_x_rn (ExpandedThingRn thing _) = isAtomicExpandedThingRn thing go_x_rn (HsRecSelRn{}) = True - isAtomicExpandedThingRn :: SrcCodeOrigin -> Bool - isAtomicExpandedThingRn (OrigExpr e) = isAtomicHsExpr e + isAtomicExpandedThingRn :: ErrCtxtMsg -> Bool + isAtomicExpandedThingRn (ExprCtxt e) = isAtomicHsExpr e isAtomicExpandedThingRn _ = False isAtomicHsExpr _ = False ===================================== compiler/GHC/Hs/Expr.hs-boot ===================================== @@ -15,8 +15,11 @@ import Language.Haskell.Syntax.Expr , GRHSs , HsUntypedSplice , HsTypedSplice + , HsMatchContext + , HsStmtContext ) -import GHC.Hs.Extension ( OutputableBndrId, GhcPass ) +import Language.Haskell.Syntax.Extension (LIdP) +import GHC.Hs.Extension ( OutputableBndrId, GhcPass, GhcRn) import GHC.Types.Name ( Name ) import Data.Bool ( Bool ) import Data.Maybe ( Maybe ) @@ -48,3 +51,6 @@ data HsUntypedSpliceResult thing , utsplice_result :: thing } | HsUntypedSpliceNested SplicePointName + +type HsMatchContextRn = HsMatchContext (LIdP GhcRn) +type HsStmtContextRn = HsStmtContext (LIdP GhcRn) ===================================== compiler/GHC/Hs/Instances.hs ===================================== @@ -36,6 +36,7 @@ import Language.Haskell.Syntax.Decls import Language.Haskell.Syntax.Decls.Overlap (OverlapMode(..)) import Language.Haskell.Syntax.Extension (Anno) import Language.Haskell.Syntax.Binds.InlinePragma (ActivationX(..), InlinePragma(..)) +import GHC.Tc.Types.ErrCtxt -- --------------------------------------------------------------------- -- Data derivations from GHC.Hs----------------------------------------- @@ -619,7 +620,7 @@ deriving instance Eq (IE GhcTc) -- --------------------------------------------------------------------- -deriving instance Data SrcCodeOrigin +deriving instance Data ErrCtxtMsg deriving instance Data XXExprGhcRn deriving instance Data a => Data (WithUserRdr a) ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -2778,7 +2778,7 @@ isHasFieldOrigin = \case RecordUpdOrigin {} -> True RecordFieldProjectionOrigin {} -> True GetFieldOrigin {} -> True - ExpansionOrigin (OrigExpr e) + ExpansionOrigin (ExprCtxt e) | HsGetField{} <- e -> True | RecordUpd{} <- e -> True | HsProjection{} <- e -> True ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -68,11 +68,11 @@ import GHC.Core.FVs( orphNamesOfTypes ) import GHC.CoreToIface import GHC.Driver.Flags -import GHC.Driver.Backend +-- import GHC.Driver.Backend import GHC.Hs hiding (HoleError) import GHC.Hs.Decls.Overlap -import GHC.Tc.Errors.Types +-- import GHC.Tc.Errors.Types import GHC.Tc.Errors.Types.PromotionErr (pprTermLevelUseCtxt) import GHC.Tc.Errors.Hole.FitTypes import GHC.Tc.Types.BasicTypes @@ -109,7 +109,7 @@ import GHC.Iface.Errors.Types import GHC.Iface.Errors.Ppr import GHC.Iface.Syntax -import GHC.Unit.State +-- import GHC.Unit.State import GHC.Unit.Module import GHC.Data.Bag ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -909,7 +909,7 @@ tcInstFun do_ql inst_final ds_flag (fun_orig, rn_fun, fun_lspan) tc_fun fun_sigm mk_herald :: HsExpr GhcTc -> HsExpr GhcRn -> CtOrigin mk_herald tc_fun arg = case fun_orig of - ExpansionOrigin (OrigStmt{}) -> ExpectedTySyntax DoStmtOrigin arg + ExpansionOrigin (StmtErrCtxt{}) -> ExpectedTySyntax DoStmtOrigin arg _ -> ExpectedFunTyArg (HsExprTcThing tc_fun) arg -- Is the argument supposed to instantiate a forall? @@ -1258,7 +1258,7 @@ expr_to_type earg = | otherwise = not_in_scope where occ = occName rdr not_in_scope = failWith $ TcRnNotInScope NotInScope rdr - go (L l (XExpr (ExpandedThingRn (OrigExpr orig) _))) = + go (L l (XExpr (ExpandedThingRn (ExprCtxt 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 ===================================== @@ -482,4 +482,6 @@ It stores the original statement (with location) and the expanded expression mkExpandedPatRn :: Pat GhcRn -> ExprLStmt GhcRn -> HsExpr GhcRn -> HsExpr GhcRn -mkExpandedPatRn pat stmt e = XExpr (ExpandedThingRn (OrigPat stmt pat) e) +mkExpandedPatRn oflav pat stmt e = XExpr $ ExpandedThingRn + { xrn_orig = StmtErrCtxtPat (HsDoStmt flav) stmt pat + , xrn_expand = e} ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -676,7 +676,7 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr ; (ds_expr, ds_res_ty, err_msg) <- expandRecordUpd record_expr possible_parents rbnds res_ty - ; addExpansionErrCtxt (OrigExpr expr) err_msg $ + ; addExpansionErrCtxt (ExprCtxt expr) err_msg $ do { -- Typecheck the expanded expression. expr' <- tcExpr ds_expr (Check ds_res_ty) -- NB: it's important to use ds_res_ty and not res_ty here. ===================================== compiler/GHC/Tc/Instance/Class.hs ===================================== @@ -1287,7 +1287,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 (ExpansionOrigin (OrigExpr (HsGetField {}))) = True + isGetFieldOrigin (ExpansionOrigin (ExprCtxt (HsGetField {}))) = True isGetFieldOrigin _ = False lookupHasFieldLabel ===================================== compiler/GHC/Tc/Types/ErrCtxt.hs ===================================== @@ -1,28 +1,28 @@ {-# LANGUAGE UndecidableInstances #-} module GHC.Tc.Types.ErrCtxt - ( ErrCtxt (..), ErrCtxtMsg(..), ErrCtxtMsgM, CodeSrcFlag (..), srcCodeOriginErrCtxMsg + ( ErrCtxt (..), ErrCtxtMsg(..), CodeSrcFlag (..) , UserSigType(..), FunAppCtxtFunArg(..) , TyConInstFlavour(..) ) where import GHC.Prelude -import GHC.Hs.Expr +import {-# SOURCE #-} GHC.Hs.Expr (SplicePointName, HsMatchContextRn, HsStmtContextRn) +import {-# SOURCE #-} GHC.Hs.Expr () -- for outputable instances +import GHC.Hs.Type () -- for outputable instances import GHC.Hs.Extension import GHC.Parser.Annotation ( LocatedN, SrcSpanAnnA ) import GHC.Tc.Errors.Types.PromotionErr ( TermLevelUseCtxt ) -import GHC.Tc.Types.Origin ( CtOrigin, UserTypeCtxt ) -import GHC.Tc.Utils.TcType ( TcType, TcTyCon ) -import GHC.Tc.Zonk.Monad ( ZonkM ) +import {-# SOURCE #-} GHC.Tc.Types.Origin ( CtOrigin, UserTypeCtxt ) +import {-# SOURCE #-} GHC.Tc.Utils.TcType ( TcType, TcTyCon ) import GHC.Types.Basic ( TyConFlavour ) import GHC.Types.Name ( Name ) -import GHC.Types.SrcLoc ( SrcSpan, unLoc ) +import GHC.Types.SrcLoc ( SrcSpan ) import GHC.Types.Var ( Id, TyCoVar ) -import GHC.Types.Var.Env ( TidyEnv ) import GHC.Unit.Types ( Module, InstantiatedModule ) @@ -32,7 +32,7 @@ import GHC.Core.PatSyn ( PatSyn ) import GHC.Core.TyCon ( TyCon ) import GHC.Core.TyCo.Rep ( Type, ThetaType, PredType ) -import GHC.Unit.State ( UnitState ) +import {-# SOURCE #-} GHC.Unit.State ( UnitState ) -- Break the module graph cycle for accesing ErrCtxtMsg in GHC.Hs.Expr import GHC.Data.FastString ( FastString ) import GHC.Utils.Outputable ( Outputable(..) ) @@ -45,7 +45,7 @@ import qualified Data.List.NonEmpty as NE -------------------------------------------------------------------------------- -type ErrCtxtMsgM = TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg) +-- type ErrCtxtMsgM = TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg) -- | Additional context to include in an error message, e.g. -- "In the type signature ...", "In the ambiguity check for ...", etc. @@ -55,7 +55,7 @@ data ErrCtxt = MkErrCtxt -- LandmarkUserSrcCode <=> this is a landmark context; do not -- discard it when trimming for display - ErrCtxtMsgM + ErrCtxtMsg -- Monadic so that we have a chance -- to deal with bound type variables just before error -- message construction @@ -63,19 +63,20 @@ data ErrCtxt = MkErrCtxt data CodeSrcFlag = VanillaUserSrcCode | LandmarkUserSrcCode - | ExpansionCodeCtxt SrcCodeOrigin + | ExpansionCodeCtxt -------------------------------------------------------------------------------- -- Error message contexts -data UserSigType p - = UserLHsSigType !(LHsSigType p) - | UserLHsType !(LHsType p) +data UserSigType + = UserLHsSigType !(LHsSigType GhcRn) + | UserLHsType !(LHsType GhcRn) -instance OutputableBndrId p => Outputable (UserSigType (GhcPass p)) where +instance Outputable UserSigType where ppr (UserLHsSigType ty) = ppr ty ppr (UserLHsType ty) = ppr ty + data FunAppCtxtFunArg = FunAppCtxtExpr !(HsExpr GhcRn) !(HsExpr GhcRn) | FunAppCtxtTy !(LHsType GhcRn) !(LHsType GhcRn) @@ -104,7 +105,7 @@ data ErrCtxtMsg -- or a type signature, or... (see 'Sig'). | SigCtxt !(Sig GhcRn) -- | In a user-written type signature. - | UserSigCtxt !UserTypeCtxt !(UserSigType GhcRn) + | UserSigCtxt !UserTypeCtxt !UserSigType -- | In a record update. | RecordUpdCtxt !(NE.NonEmpty ConLike) ![Name] ![TyCoVar] -- | In a class method. @@ -175,10 +176,10 @@ data ErrCtxtMsg | VDQWarningCtxt !TcTyCon -- | In a statement. - | forall body. - ( Anno (StmtLR GhcRn GhcRn body) ~ SrcSpanAnnA - , Outputable body - ) => StmtErrCtxt !HsStmtContextRn !(StmtLR GhcRn GhcRn body) + | StmtErrCtxt !HsStmtContextRn !(ExprLStmt GhcRn) + + -- | In patten of the statement. (c.f. MonadFailErrors) + | StmtErrCtxtPat !HsStmtContextRn !(ExprLStmt GhcRn) (Pat GhcRn) -- | In an rebindable syntax expression. | SyntaxNameCtxt !(HsExpr GhcRn) !CtOrigin !TcType !SrcSpan @@ -228,9 +229,3 @@ data ErrCtxtMsg | MergeSignaturesCtxt !UnitState !ModuleName ![InstantiatedModule] -- | While checking that a module implements a Backpack signature. | CheckImplementsCtxt !UnitState !Module !InstantiatedModule - - -srcCodeOriginErrCtxMsg :: SrcCodeOrigin -> ErrCtxtMsg -srcCodeOriginErrCtxMsg (OrigExpr e) = ExprCtxt e -srcCodeOriginErrCtxMsg (OrigStmt s f) = StmtErrCtxt (HsDoStmt f) (unLoc s) -srcCodeOriginErrCtxMsg (OrigPat s _) = StmtErrCtxt (HsDoStmt (DoExpr Nothing)) (unLoc s) ===================================== compiler/GHC/Tc/Types/LclEnv.hs ===================================== @@ -213,7 +213,7 @@ setLclEnvSrcCodeOrigin ec = modifyLclCtxt (setLclCtxtSrcCodeOrigin ec) setLclCtxtSrcCodeOrigin :: ErrCtxt -> TcLclCtxt -> TcLclCtxt setLclCtxtSrcCodeOrigin ec lclCtxt | ecs@(MkErrCtxt (ExpansionCodeCtxt{}) _ : _) <- tcl_err_ctxt lclCtxt - , MkErrCtxt (ExpansionCodeCtxt OrigExpr{}) _ <- ec + , MkErrCtxt (ExpansionCodeCtxt ExprCtxt{}) _ <- ec = lclCtxt { tcl_err_ctxt = ec : ecs } | MkErrCtxt (ExpansionCodeCtxt{}) _ : ecs <- tcl_err_ctxt lclCtxt , MkErrCtxt (ExpansionCodeCtxt{}) _ <- ec ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -654,7 +654,7 @@ data CtOrigin | AmbiguityCheckOrigin UserTypeCtxt | ImplicitLiftOrigin HsImplicitLiftSplice - | ExpansionOrigin SrcCodeOrigin -- This is due to an expansion of the original thing given by SrcCodeOrigin + | ExpansionOrigin ErrCtxtMsg -- This is due to an expansion of the original thing given by the ErrCtxtMsg | ExpectedTySyntax !CtOrigin (HsExpr GhcRn) @@ -828,11 +828,11 @@ 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@(ExplicitList {}) = ExpansionOrigin (OrigExpr e) -exprCtOrigin e@(HsIf {}) = ExpansionOrigin (OrigExpr e) -exprCtOrigin e@(HsProjection _ _) = ExpansionOrigin (OrigExpr e) -exprCtOrigin e@(RecordUpd{}) = ExpansionOrigin (OrigExpr e) -exprCtOrigin e@(HsGetField{}) = ExpansionOrigin (OrigExpr e) +exprCtOrigin e@(ExplicitList {}) = ExpansionOrigin (ExprCtxt e) +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 (HsRecSelRn f)) = OccurrenceOfRecSel $ L (getLoc $ foLabel f) (foExt f) @@ -872,21 +872,21 @@ pprCtOrigin (ExpansionOrigin o) where what :: SDoc what = case o of - OrigStmt{} -> + StmtErrCtxt{} -> text "a do statement" - OrigPat _ p -> + StmtErrCtxtPat _ p -> text "a do statement" $$ text "with the failable pattern" <+> quotes (ppr p) - OrigExpr (HsGetField _ _ (L _ f)) -> + ExprCtxt (HsGetField _ _ (L _ f)) -> hsep [text "selecting the field", quotes (ppr f)] - OrigExpr (HsOverLabel _ l) -> + ExprCtxt (HsOverLabel _ l) -> hsep [text "the overloaded label" , quotes (char '#' <> ppr l)] - OrigExpr (RecordUpd{}) -> text "a record update" - OrigExpr (ExplicitList{}) -> text "an overloaded list" - OrigExpr (HsIf{}) -> text "an if-then-else expression" - OrigExpr (HsProjection _ p) -> text "the record selector" <+> + ExprCtxt (RecordUpd{}) -> text "a record update" + ExprCtxt (ExplicitList{}) -> text "an overloaded list" + ExprCtxt (HsIf{}) -> text "an if-then-else expression" + ExprCtxt (HsProjection _ p) -> text "the record selector" <+> quotes (ppr ((FieldLabelStrings $ fmap noLocA p))) - OrigExpr e -> text "the expression" <+> (ppr e) + ExprCtxt e -> text "the expression" <+> (ppr e) pprCtOrigin (GivenSCOrigin sk d blk) = vcat [ ctoHerald <+> pprSkolInfo sk @@ -1105,13 +1105,13 @@ ppr_br (InstanceSigOrigin {}) = text "a type signature in an instance" ppr_br (AmbiguityCheckOrigin {}) = text "a type ambiguity check" ppr_br (ImpedanceMatching {}) = text "combining required constraints" ppr_br (NonLinearPatternOrigin _ pat) = hsep [text "a non-linear pattern" <+> quotes (ppr pat)] -ppr_br (ExpansionOrigin (OrigExpr (HsOverLabel _ l))) = hsep [text "the overloaded label", quotes (char '#' <> ppr l)] -ppr_br (ExpansionOrigin (OrigExpr (RecordUpd{}))) = text "a record update" -ppr_br (ExpansionOrigin (OrigExpr (ExplicitList{}))) = text "an overloaded list" -ppr_br (ExpansionOrigin (OrigExpr (HsIf{}))) = text "an if-then-else expression" -ppr_br (ExpansionOrigin (OrigExpr e)) = text "an expression" <+> ppr e -ppr_br (ExpansionOrigin (OrigStmt{})) = text "a do statement" -ppr_br (ExpansionOrigin (OrigPat{})) = text "a do statement" +ppr_br (ExpansionOrigin (ExprCtxt (HsOverLabel _ l))) = hsep [text "the overloaded label", quotes (char '#' <> ppr l)] +ppr_br (ExpansionOrigin (ExprCtxt (RecordUpd{}))) = text "a record update" +ppr_br (ExpansionOrigin (ExprCtxt (ExplicitList{}))) = text "an overloaded list" +ppr_br (ExpansionOrigin (ExprCtxt (HsIf{}))) = text "an if-then-else expression" +ppr_br (ExpansionOrigin (ExprCtxt e)) = text "an expression" <+> ppr e +ppr_br (ExpansionOrigin (StmtErrCtxt{})) = text "a do statement" +ppr_br (ExpansionOrigin (StmtErrCtxtPat{})) = text "a do statement" ppr_br (ExpectedTySyntax o _) = ppr_br o ppr_br (ExpectedFunTySyntaxOp{}) = text "a rebindable syntax operator" ppr_br (ExpectedFunTyViewPat{}) = text "a view pattern" ===================================== compiler/GHC/Tc/Types/Origin.hs-boot ===================================== @@ -4,6 +4,8 @@ import GHC.Prelude.Basic ( Int, Maybe ) import GHC.Utils.Misc ( HasDebugCallStack ) import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type ) +data CtOrigin +data UserTypeCtxt data SkolemInfoAnon data SkolemInfo data FixedRuntimeRepContext ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -1346,12 +1346,12 @@ add_expr_ctxt e thing_inside -- because it is mentioned in the error message itself ExprWithTySig _ (L _ e') _ - | XExpr (ExpandedThingRn o _) <- e' -> addExpansionErrCtxt o (ExprCtxt e) thing_inside + | 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 (srcCodeOriginErrCtxMsg o) thing_inside + XExpr (ExpandedThingRn o _) -> addExpansionErrCtxt o thing_inside -- Flip error ctxt into expansion mode _ -> addErrCtxt (ExprCtxt e) thing_inside @@ -1372,9 +1372,9 @@ addErrCtxt :: ErrCtxtMsg -> TcM a -> TcM a addErrCtxt msg = addErrCtxtM (\env -> return (env, msg)) -- See Note [ErrCtxtStack Manipulation] -addExpansionErrCtxt :: SrcCodeOrigin -> ErrCtxtMsg -> TcM a -> TcM a +addExpansionErrCtxt :: ErrCtxtMsg -> TcM a -> TcM a {-# INLINE addExpansionErrCtxt #-} -- Note [Inlining addErrCtxt] -addExpansionErrCtxt o msg = addExpansionErrCtxtM o (\env -> return (env, msg)) +addExpansionErrCtxt msg = addExpansionErrCtxtM (\env -> return (env, msg)) -- | Add a message to the error context. This message may do tidying. -- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr @@ -1383,9 +1383,9 @@ addErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) -> TcM a -> TcM a addErrCtxtM ctxt = pushCtxt (MkErrCtxt VanillaUserSrcCode ctxt) -- See Note [ErrCtxtStack Manipulation] -addExpansionErrCtxtM :: SrcCodeOrigin -> (TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) -> TcM a -> TcM a +addExpansionErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) -> TcM a -> TcM a {-# INLINE addExpansionErrCtxtM #-} -- Note [Inlining addErrCtxt] -addExpansionErrCtxtM o ctxt = pushCtxt (MkErrCtxt (ExpansionCodeCtxt o) ctxt) +addExpansionErrCtxtM ctxt = pushCtxt (MkErrCtxt ExpansionCodeCtxt ctxt) -- | Add a fixed landmark message to the error context. A landmark -- message is always sure to be reported, even if there is a lot of ===================================== compiler/GHC/Tc/Utils/TcType.hs-boot ===================================== @@ -5,6 +5,8 @@ import GHC.Prelude ( Bool ) import {-# SOURCE #-} GHC.Types.Var ( TcTyVar ) import {-# SOURCE #-} GHC.Tc.Types.Origin ( FixedRuntimeRepOrigin ) import GHC.Types.Name.Env ( NameEnv ) +import {-# SOURCE #-} GHC.Core.TyCon (TyCon) +import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type) data MetaDetails @@ -20,3 +22,6 @@ data ConcreteTvOrigin isConcreteTyVar :: TcTyVar -> Bool noConcreteTyVars :: ConcreteTyVars + +type TcTyCon = TyCon +type TcType = Type \ No newline at end of file ===================================== compiler/GHC/Types/Error.hs-boot ===================================== @@ -0,0 +1,24 @@ +module GHC.Types.Error where + +import GHC.Prelude (Maybe, Bool, IO) +import GHC.Utils.Outputable (SDoc) +import GHC.Types.SrcLoc (SrcSpan) + +data MessageClass + = MCOutput + | MCFatal + | MCInteractive + | MCDump + | MCInfo + | MCDiagnostic Severity ResolvedDiagnosticReason (Maybe DiagnosticCode) + +data Severity + = SevIgnore + | SevWarning + | SevError + +data DiagnosticCode +data ResolvedDiagnosticReason + +mkLocMessageWarningGroups :: Bool -> MessageClass -> SrcSpan -> SDoc -> SDoc +getCaretDiagnostic :: MessageClass -> SrcSpan -> IO SDoc \ No newline at end of file ===================================== compiler/GHC/Unit/State.hs-boot ===================================== @@ -0,0 +1,7 @@ +module GHC.Unit.State where + +data UnitState +data ModuleSuggestion +data ModuleOrigin +data UnusableUnit +data UnitInfo \ No newline at end of file ===================================== compiler/GHC/Utils/Logger.hs ===================================== @@ -82,7 +82,10 @@ where import GHC.Prelude import GHC.Driver.Flags -import GHC.Types.Error +import {-# SOURCE #-} GHC.Types.Error + ( MessageClass (..), Severity (..), ResolvedDiagnosticReason, DiagnosticCode + , mkLocMessageWarningGroups,getCaretDiagnostic) +import GHC.Types.Error () import GHC.Types.SrcLoc import qualified GHC.Utils.Ppr as Pretty View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ef338e58b86e668dffeab1e0053045bf... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ef338e58b86e668dffeab1e0053045bf... You're receiving this email because of your account on gitlab.haskell.org.