Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: 59b20112 by Apoorv Ingle at 2025-04-22T00:27:16-05:00 filter expr stmts error msgs - - - - - 1 changed file: - compiler/GHC/Tc/Utils/Monad.hs Changes: ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -1226,14 +1226,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] @@ -1720,9 +1720,26 @@ mkErrCtxt env ctxts -- then return empty -- just becomes too voluminous -- else go dbg 0 env ctxts = go False 0 env ctxts + where go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM [ErrCtxtMsg] go _ _ _ [] = return [] + go dbg n env ((is_landmark1, ctxt1) : (is_landmark2, ctxt2) : ctxts) + | is_landmark1 || n < mAX_CONTEXTS -- Too verbose || dbg + = do { (env', msg1) <- liftZonkM $ ctxt1 env + ; (_, msg2) <- liftZonkM $ ctxt2 env' + ; case (msg1, msg2) of + (ExprCtxt{}, StmtErrCtxt (HsDoStmt (DoExpr{})) _) + -> do { let n' = if is_landmark2 then n else n+1 + ; rest <- go dbg n' env' ctxts + ; return (msg2 : rest) } + _ + -> do { let n' = if is_landmark1 then n else n+1 + ; rest <- go dbg n' env' ((is_landmark2, ctxt2) : ctxts) + ; return (msg1 : rest) } + } + | otherwise + = go dbg n env ((is_landmark2, ctxt2) : ctxts) go dbg n env ((is_landmark, ctxt) : ctxts) | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg = do { (env', msg) <- liftZonkM $ ctxt env @@ -1732,6 +1749,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/59b20112b403b58e360e0b2296cf9ddb... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/59b20112b403b58e360e0b2296cf9ddb... You're receiving this email because of your account on gitlab.haskell.org.