Apoorv Ingle pushed to branch wip/ani/kill-SrcCodeOrigin at Glasgow Haskell Compiler / GHC Commits: b611de8e by Apoorv Ingle at 2026-03-09T00:58:26-05:00 trying out ErrCtxtMsg zonking - - - - - 4 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Zonk/TcType.hs - compiler/GHC/Tc/Zonk/Type.hs Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -1064,6 +1064,7 @@ instance Outputable XXExprGhcRn where 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 (FunAppCtxt (FunAppCtxtExpr _ e) _) = ppr_builder "<FunAppCtxt>:" (ppr e) pprCtxt _ = empty instance Outputable XXExprGhcTc where @@ -1079,6 +1080,7 @@ instance Outputable XXExprGhcTc where 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 (FunAppCtxt (FunAppCtxtExpr _ e) _) = ppr_builder "<FunAppCtxt>:" (ppr e) pprCtxt _ = empty -- e is the expanded expression, we print the original ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -1961,18 +1961,20 @@ mkErrCtxt env ctxts = go False 0 env ctxts -- regular error ctx where go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM [ErrCtxtMsg] - go _ _ _ [] = return [] + go _ _ _ [] = return [] go dbg n env (MkErrCtxt LandmarkUserSrcCode ctxt : ctxts) - = do { -- (env', msg) <- liftZonkM $ emptyTidyEnv env - ; rest <- go dbg n env ctxts - ; return (ctxt : rest) } + = do { (env', msg) <- liftZonkM $ zonkTidyErrCtxtMsg env ctxt + ; rest <- go dbg n env' ctxts + ; return (msg : rest) } go dbg n env (MkErrCtxt _ ctxt : ctxts) | n < mAX_CONTEXTS -- Too verbose || dbg - = do { -- (env', msg) <- liftZonkM $ emptyTidyEnv env - ; rest <- go dbg (n+1) env ctxts - ; return (ctxt : rest) } - | otherwise - = go dbg n env ctxts -- need to compute this for zonking + = do { (env', msg) <- liftZonkM $ zonkTidyErrCtxtMsg env ctxt + ; rest <- go dbg (n+1) env' ctxts + ; return (msg : rest) } + | otherwise -- need to compute this for zonking + = do { (env', _) <- liftZonkM $ zonkTidyErrCtxtMsg env ctxt + ; go dbg n env' ctxts + } mAX_CONTEXTS :: Int -- No more than this number of non-landmark contexts ===================================== compiler/GHC/Tc/Zonk/TcType.hs ===================================== @@ -49,7 +49,7 @@ module GHC.Tc.Zonk.TcType , tidyCt, tidyEvVar, tidyDelayedError -- ** Zonk & tidy - , zonkTidyTcType, zonkTidyTcTypes + , zonkTidyTcType, zonkTidyTcTypes, zonkTidyErrCtxtMsg , zonkTidyOrigin, zonkTidyOrigins , zonkTidyFRRInfos @@ -793,3 +793,171 @@ tidyFRROrigin env (FixedRuntimeRepOrigin ty orig) tidyEvVar :: TidyEnv -> EvVar -> EvVar tidyEvVar env var = updateIdTypeAndMult (tidyType env) var -- No need for tidyOpenType because all the free tyvars are already tidied + + + +{- +Zonk ErrCtxtMsg +-} + +zonkTidyErrCtxtMsg :: TidyEnv -> ErrCtxtMsg -> ZonkM (TidyEnv, ErrCtxtMsg) +zonkTidyErrCtxtMsg env e@(ExprCtxt{}) = return (env, e) +zonkTidyErrCtxtMsg env (ThetaCtxt ctxt theta_ty) = do + (env', theta_ty') <- zonkTidyTcTypes env theta_ty + return $ (env', ThetaCtxt ctxt theta_ty') +-- zonkTidyErrCtxtMsg env (QuantifiedCtCtxt ty) = do +-- (env', ty') <- zonkTidyTcTypes env ty +-- return $ QuantifiedCtCtxt ty' +zonkTidyErrCtxtMsg env (InferredTypeCtxt n ty) = do + (env', ty') <- zonkTidyTcType env ty + return $ (env', InferredTypeCtxt n ty') +-- zonkTidyErrCtxtMsg (RecordUpdCtxt n1 n2 tys) = do +-- tys' <- lift $ mapM zonkTcTypeToType tys +-- return $ RecordUpdCtxt n1 n2 tys' +zonkTidyErrCtxtMsg env (ClassOpCtxt n ty) = do + (env', ty') <- zonkTidyTcType env ty + return $ (env', ClassOpCtxt n ty') +zonkTidyErrCtxtMsg env (MethSigCtxt n ty1 ty2) = do + (env', ty1) <- zonkTidyTcType env ty1 + (env', ty2) <- zonkTidyTcType env ty2 + return $ (env', MethSigCtxt n ty1 ty2) +-- zonkTidyErrCtxtMsg (PatSigErrCtxt ty exp_ty) = do +-- ty' <- lift $ zonkTcTypeToType ty +-- exp_ty' <- lift $ readExpType_maybe exp_ty +-- case exp_ty' of +-- Nothing -> error "zonkTidyErrCtxtMsg PatSingErrCtxt" +-- Just exp_ty' -> do +-- exp_ty' <- lift $ zonkTcTypeToType exp_ty' +-- return $ PatSigErrCtxt ty' exp_ty' + +zonkTidyErrCtxtMsg env e@(FunAppCtxt{}) = return (env, e) +zonkTidyErrCtxtMsg env (FunTysCtxt ctxt ty i1 i2) = do + (env', ty') <- zonkTidyTcType env ty + return $ (env', FunTysCtxt ctxt ty' i1 i2) +zonkTidyErrCtxtMsg env (FunResCtxt e i1 ty1 ty2 i2 i3) = do + (env', ty1') <- zonkTidyTcType env ty1 + (env', ty2') <- zonkTidyTcType env ty2 + return $ (env', FunResCtxt e i1 ty1' ty2' i2 i3) +zonkTidyErrCtxtMsg env p = return (env, p) +{- + -- or a type signature, or... (see 'Sig'). + | SigCtxt !(Sig GhcRn) + -- | In a user-written type signature. + | UserSigCtxt !UserTypeCtxt !UserSigType + + -- | In a pattern. + | PatCtxt !(Pat GhcRn) + -- | In a pattern synonym declaration. + | PatSynDeclCtxt !Name + -- | In a pattern matching context, e.g. a equation for a function binding, + -- or a case alternative, ... + | MatchCtxt !HsMatchContextRn + -- | In a match in a pattern matching context, + -- either for an expression or for an arrow command. + | forall body. (Outputable body) + => MatchInCtxt !(Match GhcRn body) + -- | In the declaration of a type constructor. + | TyConDeclCtxt !Name !(TyConFlavour TyCon) + -- | In a type or data family instance (or default instance). + | TyConInstCtxt !Name !TyConInstFlavour + -- | In the declaration of a data constructor. + | DataConDefCtxt !(NE.NonEmpty (LocatedN Name)) + -- | In the result type of a data constructor. + | DataConResTyCtxt !(NE.NonEmpty (LocatedN Name)) + -- | In the equations for a closed type family. + | ClosedFamEqnCtxt !TyCon + -- | In the expansion of a type synonym. + | TySynErrCtxt !TyCon + -- | In a role annotation. + | RoleAnnotErrCtxt !Name + -- | In an arrow command. + | CmdCtxt !(HsCmd GhcRn) + -- | In an instance declaration. + | InstDeclErrCtxt !(Either (LHsType GhcRn) PredType) + -- | In a default declaration. + | DefaultDeclErrCtxt { ddec_in_type_list :: !Bool } + -- | In the body of a static form. + | StaticFormCtxt !(LHsExpr GhcRn) + -- | In a pattern binding. + | forall p. OutputableBndrId p + => PatMonoBindsCtxt !(LPat (GhcPass p)) !(GRHSs GhcRn (LHsExpr GhcRn)) + -- | In a foreign import/export declaration. + | ForeignDeclCtxt !(ForeignDecl GhcRn) + -- | In a record field. + | FieldCtxt !FieldLabelString + -- | In a type. + | TypeCtxt !(LHsType GhcRn) + -- | In a kind. + | KindCtxt !(LHsKind GhcRn) + -- | In an ambiguity check. + | AmbiguityCheckCtxt !UserTypeCtxt !Bool + + -- | In a term-level use of a 'Name'. + | TermLevelUseCtxt !Name !TermLevelUseCtxt + + -- | When checking the type of the @main@ function. + | MainCtxt !Name + -- | Warning emitted when inferring use of visible dependent quantification. + | VDQWarningCtxt !TcTyCon + + -- | In a statement + | forall body. + ( Anno (StmtLR GhcRn GhcRn body) ~ SrcSpanAnnA + , Outputable body + ) => StmtErrCtxt !HsStmtContextRn !(StmtLR GhcRn GhcRn body) + + -- | In a do statement. + | DoStmtErrCtxt !HsStmtContextRn !(ExprLStmt GhcRn) + + -- | In patten of the do statement. (c.f. MonadFailErrors) + | StmtErrCtxtPat !HsStmtContextRn !(ExprLStmt GhcRn) (LPat GhcRn) + + -- | In an rebindable syntax expression. + | SyntaxNameCtxt !(HsExpr GhcRn) !CtOrigin !TcType !SrcSpan + -- | In a RULE. + | RuleCtxt !FastString + -- | In a subtype check. + | SubTypeCtxt !TcType !TcType + + -- | In an export. + | forall p. OutputableBndrId p + => ExportCtxt (IE (GhcPass p)) + -- | In an export of a pattern synonym. + | PatSynExportCtxt !PatSyn + -- | In an export of a pattern synonym record field. + | PatSynRecSelExportCtxt !PatSyn !Name + + -- | In an annotation. + | forall p. OutputableBndrId p + => AnnCtxt (AnnDecl (GhcPass p)) + + -- | In a specialise pragma. + | SpecPragmaCtxt !(Sig GhcRn) + + -- | In a deriving clause. + | DerivInstCtxt !PredType + -- | In a standalone deriving clause. + | StandaloneDerivCtxt !(LHsSigWcType GhcRn) + -- | When typechecking the body of a derived instance. + | DerivBindCtxt !Id !Class ![Type] + + -- | In an untyped Template Haskell quote. + | UntypedTHBracketCtxt !(HsQuote GhcPs) + -- | In a typed Template Haskell quote. + | forall p. OutputableBndrId p + => TypedTHBracketCtxt !(LHsExpr (GhcPass p)) + -- | In an untyped Template Haskell splice or quasi-quote. + | UntypedSpliceCtxt !(HsUntypedSplice GhcPs) + -- | In a typed Template Haskell splice. + | forall p. OutputableBndrId p + => TypedSpliceCtxt !(Maybe SplicePointName) !(HsTypedSplice (GhcPass p)) + -- | In the result of a typed Template Haskell splice. + | TypedSpliceResultCtxt !(LHsExpr GhcTc) + -- | In an argument to the Template Haskell @reifyInstances@ function. + | ReifyInstancesCtxt !TH.Name ![TH.Type] + + -- | While merging Backpack signatures. + | MergeSignaturesCtxt !UnitState !ModuleName ![InstantiatedModule] + -- | While checking that a module implements a Backpack signature. + | CheckImplementsCtxt !UnitState !Module !InstantiatedModule +-} ===================================== compiler/GHC/Tc/Zonk/Type.hs ===================================== @@ -2005,4 +2005,3 @@ Quantifying here is awkward because (a) the data type is big and (b) finding the free type vars of an expression is necessarily monadic operation. (consider /\a -> f @ b, where b is side-effected to a) -} - View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b611de8e019ea78a89a98fb061ac9a7c... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b611de8e019ea78a89a98fb061ac9a7c... You're receiving this email because of your account on gitlab.haskell.org.