Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: 31224bab by Apoorv Ingle at 2025-04-27T19:31:28-05:00 exception for AppDo while making error ctxt - - - - - 1 changed file: - compiler/GHC/Tc/Utils/Monad.hs Changes: ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -1719,27 +1719,41 @@ 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 appDo <- xoptM LangExt.ApplicativeDo + if appDo + then go False 0 env ctxts + else go1 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) + go1, go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM [ErrCtxtMsg] + go1 _ _ _ [] = return [] + go1 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 + ; rest <- go1 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) + ; rest <- go1 dbg n' env' ((is_landmark2, ctxt2) : ctxts) ; return (msg1 : rest) } } | otherwise - = go dbg n env ((is_landmark2, ctxt2) : ctxts) + = go1 dbg n env ((is_landmark2, ctxt2) : ctxts) + go1 dbg n env ((is_landmark, ctxt) : ctxts) + | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg + = do { (env', msg) <- liftZonkM $ ctxt env + ; let n' = if is_landmark then n else n+1 + ; rest <- go1 dbg n' env' ctxts + ; return (msg : rest) } + | otherwise + = go1 dbg n env ctxts + + -- Applicative do doesn't use expansion yet + go _ _ _ [] = return [] go dbg n env ((is_landmark, ctxt) : ctxts) | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg = do { (env', msg) <- liftZonkM $ ctxt env @@ -1749,13 +1763,6 @@ 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/31224babec2e805ed494feebd544129c... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/31224babec2e805ed494feebd544129c... You're receiving this email because of your account on gitlab.haskell.org.