diff options
Diffstat (limited to 'compiler/GHC/Tc/Errors.hs')
| -rw-r--r-- | compiler/GHC/Tc/Errors.hs | 113 |
1 files changed, 48 insertions, 65 deletions
diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs index abb58cd58b..dda7c0eeac 100644 --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -50,7 +50,7 @@ import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Name.Set import GHC.Data.Bag -import GHC.Utils.Error ( pprLocMsgEnvelope ) +import GHC.Utils.Error (diagReasonSeverity, pprLocMsgEnvelope ) import GHC.Types.Basic import GHC.Types.Error import GHC.Core.ConLike ( ConLike(..)) @@ -66,10 +66,9 @@ import GHC.Data.Maybe import qualified GHC.LanguageExtensions as LangExt import GHC.Utils.FV ( fvVarList, unionFV ) -import Control.Monad ( unless, when ) +import Control.Monad ( unless, when, forM_ ) import Data.Foldable ( toList ) import Data.List ( partition, mapAccumL, sortBy, unfoldr ) -import Data.Traversable ( for ) import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits ) @@ -132,34 +131,24 @@ reportUnsolved :: WantedConstraints -> TcM (Bag EvBind) reportUnsolved wanted = do { binds_var <- newTcEvBinds ; defer_errors <- goptM Opt_DeferTypeErrors - ; warn_errors <- woptM Opt_WarnDeferredTypeErrors -- implement #10283 - ; let type_errors | not defer_errors = Just ErrorWithoutFlag - | warn_errors = Just (WarningWithFlag Opt_WarnDeferredTypeErrors) - | otherwise = Nothing + ; let type_errors | not defer_errors = ErrorWithoutFlag + | otherwise = WarningWithFlag Opt_WarnDeferredTypeErrors ; defer_holes <- goptM Opt_DeferTypedHoles - ; warn_holes <- woptM Opt_WarnTypedHoles - ; let expr_holes | not defer_holes = Just ErrorWithoutFlag - | warn_holes = Just (WarningWithFlag Opt_WarnTypedHoles) - | otherwise = Nothing + ; let expr_holes | not defer_holes = ErrorWithoutFlag + | otherwise = WarningWithFlag Opt_WarnTypedHoles ; partial_sigs <- xoptM LangExt.PartialTypeSignatures - ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures ; let type_holes | not partial_sigs - = Just ErrorWithoutFlag - | warn_partial_sigs - = Just (WarningWithFlag Opt_WarnPartialTypeSignatures) + = ErrorWithoutFlag | otherwise - = Nothing + = WarningWithFlag Opt_WarnPartialTypeSignatures ; defer_out_of_scope <- goptM Opt_DeferOutOfScopeVariables - ; warn_out_of_scope <- woptM Opt_WarnDeferredOutOfScopeVariables ; let out_of_scope_holes | not defer_out_of_scope - = Just ErrorWithoutFlag - | warn_out_of_scope - = Just (WarningWithFlag Opt_WarnDeferredOutOfScopeVariables) + = ErrorWithoutFlag | otherwise - = Nothing + = WarningWithFlag Opt_WarnDeferredOutOfScopeVariables ; report_unsolved type_errors expr_holes type_holes out_of_scope_holes @@ -180,13 +169,11 @@ reportAllUnsolved wanted = do { ev_binds <- newNoTcEvBinds ; partial_sigs <- xoptM LangExt.PartialTypeSignatures - ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures - ; let type_holes | not partial_sigs = Just ErrorWithoutFlag - | warn_partial_sigs = Just (WarningWithFlag Opt_WarnPartialTypeSignatures) - | otherwise = Nothing + ; let type_holes | not partial_sigs = ErrorWithoutFlag + | otherwise = WarningWithFlag Opt_WarnPartialTypeSignatures - ; report_unsolved (Just ErrorWithoutFlag) - (Just ErrorWithoutFlag) type_holes (Just ErrorWithoutFlag) + ; report_unsolved ErrorWithoutFlag + ErrorWithoutFlag type_holes ErrorWithoutFlag ev_binds wanted } -- | Report all unsolved goals as warnings (but without deferring any errors to @@ -195,17 +182,17 @@ reportAllUnsolved wanted warnAllUnsolved :: WantedConstraints -> TcM () warnAllUnsolved wanted = do { ev_binds <- newTcEvBinds - ; report_unsolved (Just WarningWithoutFlag) - (Just WarningWithoutFlag) - (Just WarningWithoutFlag) - (Just WarningWithoutFlag) + ; report_unsolved WarningWithoutFlag + WarningWithoutFlag + WarningWithoutFlag + WarningWithoutFlag ev_binds wanted } -- | Report unsolved goals as errors or warnings. -report_unsolved :: Maybe DiagnosticReason -- Deferred type errors - -> Maybe DiagnosticReason -- Expression holes - -> Maybe DiagnosticReason -- Type holes - -> Maybe DiagnosticReason -- Out of scope holes +report_unsolved :: DiagnosticReason -- Deferred type errors + -> DiagnosticReason -- Expression holes + -> DiagnosticReason -- Type holes + -> DiagnosticReason -- Out of scope holes -> EvBindsVar -- cec_binds -> WantedConstraints -> TcM () report_unsolved type_errors expr_holes @@ -320,15 +307,15 @@ data ReportErrCtxt -- into warnings, and emit evidence bindings -- into 'cec_binds' for unsolved constraints - , cec_defer_type_errors :: Maybe DiagnosticReason -- Nothing: Defer type errors until runtime + , cec_defer_type_errors :: DiagnosticReason -- Defer type errors until runtime -- cec_expr_holes is a union of: -- cec_type_holes - a set of typed holes: '_', '_a', '_foo' -- cec_out_of_scope_holes - a set of variables which are -- out of scope: 'x', 'y', 'bar' - , cec_expr_holes :: Maybe DiagnosticReason -- Holes in expressions. Nothing: defer/suppress errors. - , cec_type_holes :: Maybe DiagnosticReason -- Holes in types. Nothing: defer/suppress errors. - , cec_out_of_scope_holes :: Maybe DiagnosticReason -- Out of scope holes. Nothing: defer/suppress errors. + , cec_expr_holes :: DiagnosticReason -- Holes in expressions. + , cec_type_holes :: DiagnosticReason -- Holes in types. + , cec_out_of_scope_holes :: DiagnosticReason -- Out of scope holes. , cec_warn_redundant :: Bool -- True <=> -Wredundant-constraints , cec_expand_syns :: Bool -- True <=> -fprint-expanded-synonyms @@ -361,19 +348,19 @@ instance Outputable ReportErrCtxt where -- | Returns True <=> the ReportErrCtxt indicates that something is deferred deferringAnyBindings :: ReportErrCtxt -> Bool -- Don't check cec_type_holes, as these don't cause bindings to be deferred -deferringAnyBindings (CEC { cec_defer_type_errors = Just ErrorWithoutFlag - , cec_expr_holes = Just ErrorWithoutFlag - , cec_out_of_scope_holes = Just ErrorWithoutFlag }) = False -deferringAnyBindings _ = True +deferringAnyBindings (CEC { cec_defer_type_errors = ErrorWithoutFlag + , cec_expr_holes = ErrorWithoutFlag + , cec_out_of_scope_holes = ErrorWithoutFlag }) = False +deferringAnyBindings _ = True maybeSwitchOffDefer :: EvBindsVar -> ReportErrCtxt -> ReportErrCtxt -- Switch off defer-type-errors inside CoEvBindsVar -- See Note [Failing equalities with no evidence bindings] maybeSwitchOffDefer evb ctxt | CoEvBindsVar{} <- evb - = ctxt { cec_defer_type_errors = Just ErrorWithoutFlag - , cec_expr_holes = Just ErrorWithoutFlag - , cec_out_of_scope_holes = Just ErrorWithoutFlag } + = ctxt { cec_defer_type_errors = ErrorWithoutFlag + , cec_expr_holes = ErrorWithoutFlag + , cec_out_of_scope_holes = ErrorWithoutFlag } | otherwise = ctxt @@ -727,22 +714,22 @@ mkSkolReporter ctxt cts reportHoles :: [Ct] -- other (tidied) constraints -> ReportErrCtxt -> [Hole] -> TcM () -reportHoles tidy_cts ctxt - = mapM_ $ \hole -> unless (ignoreThisHole ctxt hole) $ - do { msg_mb <- mkHoleError tidy_cts ctxt hole - ; whenIsJust msg_mb reportDiagnostic } +reportHoles tidy_cts ctxt holes + = do df <- getDynFlags + forM_ holes $ \hole -> unless (ignoreThisHole df ctxt hole) $ + mkHoleError tidy_cts ctxt hole >>= reportDiagnostic -ignoreThisHole :: ReportErrCtxt -> Hole -> Bool +ignoreThisHole :: DynFlags -> ReportErrCtxt -> Hole -> Bool -- See Note [Skip type holes rapidly] -ignoreThisHole ctxt hole +ignoreThisHole df ctxt hole = case hole_sort hole of ExprHole {} -> False TypeHole -> ignore_type_hole ConstraintHole -> ignore_type_hole where - ignore_type_hole = case cec_type_holes ctxt of - Nothing -> True - _ -> False + ignore_type_hole = case diagReasonSeverity df (cec_type_holes ctxt) of + SevIgnore -> True + _ -> False {- Note [Skip type holes rapidly] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -894,14 +881,11 @@ suppressGroup mk_err ctxt cts maybeReportError :: ReportErrCtxt -> Ct -> Report -> TcM () maybeReportError ctxt ct report - | Just reason <- cec_defer_type_errors ctxt = unless (cec_suppress ctxt) $ -- Some worse error has occurred, so suppress this diagnostic - do msg <- mkErrorReport reason ctxt (ctLocEnv (ctLoc ct)) report + do let reason = cec_defer_type_errors ctxt + msg <- mkErrorReport reason ctxt (ctLocEnv (ctLoc ct)) report reportDiagnostic msg - | otherwise - = return () -- nothing to report - addDeferredBinding :: ReportErrCtxt -> Report -> Ct -> TcM () -- See Note [Deferring coercion errors to runtime] addDeferredBinding ctxt err ct @@ -1164,7 +1148,7 @@ See also 'reportUnsolved'. ---------------- -- | Constructs a new hole error, unless this is deferred. See Note [Constructing Hole Errors]. -mkHoleError :: [Ct] -> ReportErrCtxt -> Hole -> TcM (Maybe (MsgEnvelope DiagnosticMessage)) +mkHoleError :: [Ct] -> ReportErrCtxt -> Hole -> TcM (MsgEnvelope DiagnosticMessage) mkHoleError _tidy_simples ctxt hole@(Hole { hole_occ = occ , hole_ty = hole_ty , hole_loc = ct_loc }) @@ -1180,8 +1164,7 @@ mkHoleError _tidy_simples ctxt hole@(Hole { hole_occ = occ (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ)) ; maybeAddDeferredBindings ctxt hole err - ; for (cec_out_of_scope_holes ctxt) $ \ rea -> - mkErrorReportNC rea lcl_env err + ; mkErrorReportNC (cec_out_of_scope_holes ctxt) lcl_env err -- Use NC variant: the context is generally not helpful here } where @@ -1223,7 +1206,7 @@ mkHoleError tidy_simples ctxt hole@(Hole { hole_occ = occ ; let holes | ExprHole _ <- sort = cec_expr_holes ctxt | otherwise = cec_type_holes ctxt - ; for holes $ \ rea -> mkErrorReport rea ctxt lcl_env err + ; mkErrorReport holes ctxt lcl_env err } where @@ -1260,7 +1243,7 @@ mkHoleError tidy_simples ctxt hole@(Hole { hole_occ = occ -- hole, via kind casts type_hole_hint - | Just ErrorWithoutFlag <- cec_type_holes ctxt + | ErrorWithoutFlag <- cec_type_holes ctxt = text "To use the inferred type, enable PartialTypeSignatures" | otherwise = empty |