Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: 1dad95ad by Apoorv Ingle at 2025-04-21T19:29:47-05:00 filter expr stmts error msgs - - - - - 1 changed file: - compiler/GHC/Tc/Utils/Monad.hs Changes: ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -238,6 +238,7 @@ import Data.IORef import Control.Monad import qualified Data.Map as Map +import Data.List (tails) import GHC.Core.Coercion (isReflCo) @@ -1226,14 +1227,14 @@ setErrCtxt ctxt = updLclEnv (setLclEnvErrCtxt ctxt) -- | Add a fixed message to the error context. This message should not -- do any tidying. --- no op in generated code +-- NB. No op in generated code -- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr addErrCtxt :: ErrCtxtMsg -> TcM a -> TcM a {-# INLINE addErrCtxt #-} -- Note [Inlining addErrCtxt] addErrCtxt msg = addErrCtxtM (\env -> return (env, msg)) -- | Add a message to the error context. This message may do tidying. --- no op in generated code +-- NB. No op in generated code -- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr addErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) -> TcM a -> TcM a {-# INLINE addErrCtxtM #-} -- Note [Inlining addErrCtxt] @@ -1719,12 +1720,13 @@ mkErrCtxt env ctxts -- if dbg -- In -dppr-debug style the output -- then return empty -- just becomes too voluminous -- else go dbg 0 env ctxts - = go False 0 env ctxts + = do xs <- go False 0 env ctxts + return $ take mAX_CONTEXTS (filter_stmt_adj xs) where go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM [ErrCtxtMsg] go _ _ _ [] = return [] go dbg n env ((is_landmark, ctxt) : ctxts) - | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg + | is_landmark || n < (mAX_CONTEXTS + 1) -- Too verbose || dbg = do { (env', msg) <- liftZonkM $ ctxt env ; let n' = if is_landmark then n else n+1 ; rest <- go dbg n' env' ctxts @@ -1732,6 +1734,14 @@ mkErrCtxt env ctxts | otherwise = go dbg n env ctxts + filter_stmt_adj :: [ErrCtxtMsg] -> [ErrCtxtMsg] + filter_stmt_adj = concat . map stmtAdj . tails + + stmtAdj :: [ErrCtxtMsg] -> [ErrCtxtMsg] + stmtAdj (ExprCtxt{} : StmtErrCtxt{} : _ ) = [] + stmtAdj (s : _ ) = [s] + stmtAdj xs = xs + mAX_CONTEXTS :: Int -- No more than this number of non-landmark contexts mAX_CONTEXTS = 3 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1dad95ad19b6457f4818ed828c85cc6d... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1dad95ad19b6457f4818ed828c85cc6d... You're receiving this email because of your account on gitlab.haskell.org.