GitLab

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:

@@ -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,