Simon Peyton Jones pushed to branch wip/T23162-part2 at Glasgow Haskell Compiler / GHC Commits: 4475b266 by Simon Peyton Jones at 2025-12-10T13:01:13+00:00 More improvements in error reporting - - - - - 5 changed files: - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Solver.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Utils/Monad.hs Changes: ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -87,7 +87,7 @@ import qualified GHC.Data.Strict as Strict import Language.Haskell.Syntax.Basic (FieldLabelString(..)) -import Control.Monad ( unless, when, foldM, forM_ ) +import Control.Monad ( when, foldM, forM_ ) import Data.Bifunctor ( bimap ) import Data.Foldable ( toList ) import Data.Function ( on ) @@ -482,12 +482,15 @@ mkErrorItem ct CIrredCan (IrredCt { ir_reason = reason }) -> Just reason _ -> Nothing - ; return $ Just $ EI { ei_pred = ctPred ct - , ei_evdest = m_evdest - , ei_flavour = flav - , ei_loc = loc - , ei_m_reason = m_reason - , ei_suppress = suppress }} + insoluble_ct = insolubleCt ct + + ; return $ Just $ EI { ei_pred = ctPred ct + , ei_evdest = m_evdest + , ei_flavour = flav + , ei_loc = loc + , ei_m_reason = m_reason + , ei_insoluble = insoluble_ct + , ei_suppress = suppress }} -- | Actually report this 'ErrorItem'. unsuppressErrorItem :: ErrorItem -> ErrorItem @@ -648,7 +651,7 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics , ("Homo eqs", is_homo_equality, True, mkGroupReporter mkEqErr) , ("Other eqs", is_equality, True, mkGroupReporter mkEqErr) - , ("Insoluble fundeps", is_insoluble_fundep, True, mkGroupReporter mkDictErr) + , ("Insoluble fundeps", is_insoluble, True, mkGroupReporter mkDictErr) ] -- report2: we suppress these if there are insolubles elsewhere in the tree @@ -666,9 +669,7 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics -- I think all given residuals are equalities -- Constraints that have insoluble functional dependencies - is_insoluble_fundep item _ = case ei_m_reason item of - Just InsolubleFunDepReason -> True - _ -> False + is_insoluble item _ = ei_insoluble item -- Things like (Int ~N Bool) utterly_wrong _ (EqPred NomEq ty1 ty2) = isRigidTy ty1 && isRigidTy ty2 @@ -1305,18 +1306,30 @@ maybeReportError :: SolverReportErrCtxt maybeReportError ctxt items@(item1:|_) (SolverReport { sr_important_msg = important , sr_supplementary = supp , sr_hints = hints }) - = unless (cec_suppress ctxt -- Some worse error has occurred, so suppress this diagnostic - || all ei_suppress items) $ - -- if they're all to be suppressed, report nothing - -- if at least one is not suppressed, do report: - -- the function that generates the error message - -- should look for an unsuppressed error item - do let reason | any (nonDeferrableOrigin . errorItemOrigin) items = ErrorWithoutFlag - | otherwise = cec_defer_type_errors ctxt - -- See Note [No deferring for multiplicity errors] - diag = TcRnSolverReport important reason - msg <- mkErrorReport (ctLocEnv (errorItemCtLoc item1)) diag (Just ctxt) supp hints - reportDiagnostic msg + | suppress_group = return () + | otherwise = do { msg <- mkErrorReport loc_env diag (Just ctxt) supp hints + ; reportDiagnostic msg } + where + reason | any (nonDeferrableOrigin . errorItemOrigin) items = ErrorWithoutFlag + | otherwise = cec_defer_type_errors ctxt + -- See Note [No deferring for multiplicity errors] + diag = TcRnSolverReport important reason + loc_env = ctLocEnv (errorItemCtLoc item1) + + suppress_group + | all ei_suppress items + = True -- If they are all suppressed (notably, have been rewritten by another unsolved wanted) + -- report nothing. (If at least one is not suppressed, do report: the function that + -- generates the error message should look for an unsuppressed error item.) + + | any ei_insoluble items + = False -- Don't suppress insolubles even if cec_suppress is True + + | cec_suppress ctxt + = True -- Some earlier error has occurred, so suppress this diagnostic + + | otherwise + = False addSolverDeferredBinding :: SolverReport -> ErrorItem -> TcM () addSolverDeferredBinding err item = @@ -2089,7 +2102,7 @@ misMatchOrCND :: SolverReportErrCtxt -> ErrorItem -> TcType -> TcType -> TcM MismatchMsg -- If oriented then ty1 is actual, ty2 is expected misMatchOrCND ctxt item ty1 ty2 - | insoluble_item -- See Note [Insoluble mis-match] + | ei_insoluble item -- See Note [Insoluble mis-match] || (isRigidTy ty1 && isRigidTy ty2) || (ei_flavour item == Given) || null givens @@ -2101,10 +2114,6 @@ misMatchOrCND ctxt item ty1 ty2 = mkCouldNotDeduceErr givens (item :| []) (Just $ CND_ExpectedActual level ty1 ty2) where - insoluble_item = case ei_m_reason item of - Nothing -> False - Just r -> isInsolubleReason r - level = ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel givens = [ given | given <- getUserGivens ctxt, ic_given_eqs given /= NoGivenEqs ] -- Keep only UserGivens that have some equalities. ===================================== compiler/GHC/Tc/Errors/Types.hs ===================================== @@ -5438,7 +5438,10 @@ data ErrorItem , ei_loc :: CtLoc , ei_m_reason :: Maybe CtIrredReason -- If this ErrorItem was made from a -- CtIrred, this stores the reason - , ei_suppress :: Bool -- Suppress because of + , ei_insoluble :: Bool -- True if the constraint is defdinitely insoluble + -- Cache of `insolubleCt` + + , ei_suppress :: Bool -- Suppress because of -- Note [Wanteds rewrite Wanteds: rewriter-sets] -- in GHC.Tc.Constraint } ===================================== compiler/GHC/Tc/Solver.hs ===================================== @@ -723,28 +723,46 @@ they can still be solved: -} tcCheckGivens :: InertSet -> Bag EvVar -> TcM (Maybe InertSet) --- ^ Return (Just new_inerts) if the Givens are satisfiable, Nothing if definitely --- contradictory. +-- ^ Return (Just new_inerts) if the Givens are satisfiable, +-- Nothing if definitely contradictory. +-- So Nothing says something definite; if in doubt return Just -- -- See Note [Pattern match warnings with insoluble Givens] above. -tcCheckGivens inerts given_ids = do - mb_res <- tryM $ runTcSInerts inerts $ do - traceTcS "checkGivens {" (ppr inerts <+> ppr given_ids) - lcl_env <- TcS.getLclEnv - let given_loc = mkGivenLoc topTcLevel (getSkolemInfo unkSkol) (mkCtLocEnv lcl_env) - let given_cts = mkGivens given_loc (bagToList given_ids) - -- See Note [Superclasses and satisfiability] - solveSimpleGivens given_cts - insols <- getInertInsols - insols <- try_harder insols - traceTcS "checkGivens }" (ppr insols) - return (isEmptyBag insols) - case mb_res of - Left _ -> return (Just inerts) - Right (sat, new_inerts) - | sat -> return (Just new_inerts) - | otherwise -> return Nothing -- Definitely unsatisfiable +tcCheckGivens inerts given_ids + = do { traceTc "checkGivens {" (ppr inerts <+> ppr given_ids) + + ; lcl_env <- TcM.getLclEnv + ; let given_loc = mkGivenLoc topTcLevel (getSkolemInfo unkSkol) (mkCtLocEnv lcl_env) + given_cts = mkGivens given_loc (bagToList given_ids) + -- See Note [Superclasses and satisfiability] + + ; mb_res <- tryM $ -- try_to_solve may throw an exception; + -- e.g. reduction stack overflow + discardErrs $ -- An exception id not an error; + -- just means "not definitely unsat" + runTcSInerts inerts $ + try_to_solve given_cts + + -- If mb_res = Left err, solving threw an exception, e.g. reduction stack + -- overflow. So return the original incoming inerts to say "not definitely + -- unsatisfiable". + ; let res = case mb_res of + Right res -> res + Left {} -> Just inerts + + ; traceTc "checkGivens }" (ppr res) + ; return res } + where + try_to_solve :: [Ct] -> TcS (Maybe InertSet) + try_to_solve given_cts + = do { solveSimpleGivens given_cts + ; insols <- getInertInsols + ; insols <- try_harder insols + ; if isEmptyBag insols + then do { new_inerts <- getInertSet; return (Just new_inerts) } + else return Nothing } -- Definitely unsatisfiable + try_harder :: Cts -> TcS Cts -- Maybe we have to search up the superclass chain to find -- an unsatisfiable constraint. Example: pmcheck/T3927b. @@ -760,27 +778,25 @@ tcCheckGivens inerts given_ids = do tcCheckWanteds :: InertSet -> ThetaType -> TcM Bool -- ^ Return True if the Wanteds are soluble, False if not -tcCheckWanteds inerts wanteds = do - cts <- newWanteds PatCheckOrigin wanteds - (sat, _new_inerts) <- runTcSInerts inerts $ do - traceTcS "checkWanteds {" (ppr inerts <+> ppr wanteds) - -- See Note [Superclasses and satisfiability] - wcs <- solveWanteds (mkSimpleWC cts) - traceTcS "checkWanteds }" (ppr wcs) - return (isSolvedWC wcs) - return sat +tcCheckWanteds inerts wanteds + = do { cts <- newWanteds PatCheckOrigin wanteds + ; runTcSInerts inerts $ + do { traceTcS "checkWanteds {" (ppr inerts <+> ppr wanteds) + -- See Note [Superclasses and satisfiability] + ; wcs <- solveWanteds (mkSimpleWC cts) + ; traceTcS "checkWanteds }" (ppr wcs) + ; return (isSolvedWC wcs) } } -- | Normalise a type as much as possible using the given constraints. -- See @Note [tcNormalise]@. tcNormalise :: InertSet -> Type -> TcM Type tcNormalise inerts ty = do { norm_loc <- getCtLocM PatCheckOrigin Nothing - ; (res, _new_inerts) <- runTcSInerts inerts $ - do { traceTcS "tcNormalise {" (ppr inerts) - ; ty' <- rewriteType norm_loc ty - ; traceTcS "tcNormalise }" (ppr ty') - ; pure ty' } - ; return res } + ; runTcSInerts inerts $ + do { traceTcS "tcNormalise {" (ppr inerts) + ; ty' <- rewriteType norm_loc ty + ; traceTcS "tcNormalise }" (ppr ty') + ; pure ty' } } {- Note [Superclasses and satisfiability] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -1170,15 +1170,12 @@ runTcSEqualities thing_inside -- | A variant of 'runTcS' that takes and returns an 'InertSet' for -- later resumption of the 'TcS' session. -runTcSInerts :: InertSet -> TcS a -> TcM (a, InertSet) -runTcSInerts inerts tcs +runTcSInerts :: InertSet -> TcS a -> TcM a +runTcSInerts inerts thing_inside = do { ev_binds_var <- TcM.newTcEvBinds ; runTcSWithEvBinds' (vanillaTcSMode { tcsmResumable = True }) ev_binds_var $ - do { setInertSet inerts - ; a <- tcs - ; new_inerts <- getInertSet - ; return (a, new_inerts) } } + do { setInertSet inerts; thing_inside } } runTcSWithEvBinds :: EvBindsVar -> TcS a ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -11,7 +11,7 @@ -- getters...). module GHC.Tc.Utils.Monad( -- * Initialisation - initTc, initTcWithGbl, initTcInteractive, initTcRnIf, + initTc, initTcInteractive, initTcRnIf, -- * Simple accessors discardResult, View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4475b2662c3f88136e4eafe961b0bb42... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4475b2662c3f88136e4eafe961b0bb42... You're receiving this email because of your account on gitlab.haskell.org.