diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs
index 6d396f88a8d4845725e9207ddd29e7ec8c516e01..a5fc9f92e0333d99a59f5fc92ee4e3c33cfaa6d4 100644
--- a/compiler/GHC/Tc/Errors.hs
+++ b/compiler/GHC/Tc/Errors.hs
@@ -69,6 +69,7 @@ import GHC.Utils.FV ( fvVarList, unionFV )
import Control.Monad ( unless, when )
import Data.Foldable ( toList )
import Data.List ( partition, mapAccumL, sortBy, unfoldr )
+import Data.Traversable ( for )
import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits )
@@ -733,30 +734,21 @@ reportHoles tidy_cts ctxt
mkUserTypeErrorReporter :: Reporter
mkUserTypeErrorReporter ctxt
- = mapM_ $ \ct -> do
- let mk_msg rea = mkUserTypeError rea ctxt ct
-
- whenIsJust (cec_defer_type_errors ctxt) $ \deferReason -> do
- msg <- mk_msg deferReason
- maybeReportError ctxt msg
-
- -- No matter what, add the deferred bindings.
- mk_msg ErrorWithoutFlag >>= \msg -> addDeferredBinding ctxt msg ct
-
-mkUserTypeError :: DiagnosticReason -> ReportErrCtxt -> Ct -> TcM (MsgEnvelope DiagnosticMessage)
-mkUserTypeError reason ctxt ct = mkErrorMsgFromCt reason ctxt ct
- $ important
- $ pprUserTypeErrorTy
- $ case getUserTypeErrorMsg ct of
- Just msg -> msg
- Nothing -> pprPanic "mkUserTypeError" (ppr ct)
+ = mapM_ $ \ct -> do { let err = mkUserTypeError ct
+ ; maybeReportError ctxt ct err
+ ; addDeferredBinding ctxt err ct }
+mkUserTypeError :: Ct -> Report
+mkUserTypeError ct = important
+ $ pprUserTypeErrorTy
+ $ case getUserTypeErrorMsg ct of
+ Just msg -> msg
+ Nothing -> pprPanic "mkUserTypeError" (ppr ct)
mkGivenErrorReporter :: Reporter
-- See Note [Given errors]
mkGivenErrorReporter ctxt cts
= do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
- ; dflags <- getDynFlags
; let (implic:_) = cec_encl ctxt
-- Always non-empty when mkGivenErrorReporter is called
ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (ic_env implic))
@@ -769,7 +761,9 @@ mkGivenErrorReporter ctxt cts
report = important inaccessible_msg `mappend`
mk_relevant_bindings binds_msg
- ; err <- mkEqErr_help (WarningWithFlag Opt_WarnInaccessibleCode) dflags ctxt report ct' ty1 ty2
+ ; report <- mkEqErr_help ctxt report ct' ty1 ty2
+ ; err <- mkErrorReport (WarningWithFlag Opt_WarnInaccessibleCode) ctxt
+ (ctLocEnv (ctLoc ct')) report
; traceTc "mkGivenErrorReporter" (ppr ct)
; reportDiagnostic err }
@@ -819,7 +813,7 @@ pattern match which binds some equality constraints. If we
find one, we report the insoluble Given.
-}
-mkGroupReporter :: (DiagnosticReason -> ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage))
+mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM Report)
-- Make error message for a group
-> Reporter -- Deal with lots of constraints
-- Group together errors from same location,
@@ -828,7 +822,7 @@ mkGroupReporter mk_err ctxt cts
= mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc cts)
-- Like mkGroupReporter, but doesn't actually print error messages
-mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage))
+mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM Report)
-> Reporter
mkSuppressReporter mk_err ctxt cts
= mapM_ (suppressGroup mk_err ctxt . toList) (equivClasses cmp_loc cts)
@@ -847,44 +841,50 @@ cmp_loc ct1 ct2 = get ct1 `compare` get ct2
-- Reduce duplication by reporting only one error from each
-- /starting/ location even if the end location differs
-reportGroup :: (DiagnosticReason -> ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage))
- -> Reporter
-reportGroup mk_err ctxt cts =
- ASSERT( not (null cts))
- do { let mk_msg rea = mk_err rea ctxt cts
- ; whenIsJust (cec_defer_type_errors ctxt) $ \deferReason -> do
- msg <- mk_msg deferReason
- maybeReportError ctxt msg
+reportGroup :: (ReportErrCtxt -> [Ct] -> TcM Report) -> Reporter
+reportGroup mk_err ctxt cts
+ | ct1 : _ <- cts =
+ do { err <- mk_err ctxt cts
+ ; traceTc "About to maybeReportErr" $
+ vcat [ text "Constraint:" <+> ppr cts
+ , text "cec_suppress =" <+> ppr (cec_suppress ctxt)
+ , text "cec_defer_type_errors =" <+> ppr (cec_defer_type_errors ctxt) ]
+ ; maybeReportError ctxt ct1 err
-- But see Note [Always warn with -fdefer-type-errors]
; traceTc "reportGroup" (ppr cts)
- ; mapM_ (\ct -> mk_msg ErrorWithoutFlag >>= \e -> addDeferredBinding ctxt e ct) cts }
+ ; mapM_ (addDeferredBinding ctxt err) cts }
-- Add deferred bindings for all
-- Redundant if we are going to abort compilation,
-- but that's hard to know for sure, and if we don't
-- abort, we need bindings for all (e.g. #12156)
+ | otherwise = panic "empty reportGroup"
-- like reportGroup, but does not actually report messages. It still adds
-- -fdefer-type-errors bindings, though.
-suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage)) -> Reporter
+suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM Report) -> Reporter
suppressGroup mk_err ctxt cts
= do { err <- mk_err ctxt cts
; traceTc "Suppressing errors for" (ppr cts)
; mapM_ (addDeferredBinding ctxt err) cts }
-maybeReportError :: ReportErrCtxt -> MsgEnvelope DiagnosticMessage -> TcM ()
-maybeReportError ctxt msg =
- unless (cec_suppress ctxt) $ -- Some worse error has occurred, so suppress this diagnostic
- reportDiagnostic msg
+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
+ reportDiagnostic msg
-addDeferredBinding :: ReportErrCtxt -> MsgEnvelope DiagnosticMessage -> Ct -> TcM ()
+ | otherwise
+ = return () -- nothing to report
+
+addDeferredBinding :: ReportErrCtxt -> Report -> Ct -> TcM ()
-- See Note [Deferring coercion errors to runtime]
addDeferredBinding ctxt err ct
| deferringAnyBindings ctxt
, CtWanted { ctev_pred = pred, ctev_dest = dest } <- ctEvidence ct
-- Only add deferred bindings for Wanted constraints
- = do { dflags <- getDynFlags
- ; let err_tm = mkErrorTerm dflags pred err
- ev_binds_var = cec_binds ctxt
+ = do { err_tm <- mkErrorTerm ctxt (ctLoc ct) pred err
+ ; let ev_binds_var = cec_binds ctxt
; case dest of
EvVarDest evar
@@ -898,13 +898,16 @@ addDeferredBinding ctxt err ct
| otherwise -- Do not set any evidence for Given/Derived
= return ()
-mkErrorTerm :: DynFlags -> Type -- of the error term
- -> MsgEnvelope DiagnosticMessage -> EvTerm
-mkErrorTerm dflags ty err = evDelayedError ty err_fs
- where
- err_msg = pprLocMsgEnvelope err
- err_fs = mkFastString $ showSDoc dflags $
- err_msg $$ text "(deferred type error)"
+mkErrorTerm :: ReportErrCtxt -> CtLoc -> Type -- of the error term
+ -> Report -> TcM EvTerm
+mkErrorTerm ctxt ct_loc ty report
+ = do { msg <- mkErrorReport ErrorWithoutFlag ctxt (ctLocEnv ct_loc) report
+ ; dflags <- getDynFlags
+ ; let err_msg = pprLocMsgEnvelope msg
+ err_fs = mkFastString $ showSDoc dflags $
+ err_msg $$ text "(deferred type error)"
+
+ ; return $ evDelayedError ty err_fs }
tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct])
-- Use the first reporter in the list whose predicate says True
@@ -974,11 +977,6 @@ pprWithArising (ct:cts)
ppr_one ct' = hang (parens (pprType (ctPred ct')))
2 (pprCtLoc (ctLoc ct'))
-mkErrorMsgFromCt :: DiagnosticReason
- -> ReportErrCtxt -> Ct -> Report -> TcM (MsgEnvelope DiagnosticMessage)
-mkErrorMsgFromCt reason ctxt ct report
- = mkErrorReport reason ctxt (ctLocEnv (ctLoc ct)) report
-
mkErrorReport :: DiagnosticReason
-> ReportErrCtxt
-> TcLclEnv
@@ -993,6 +991,17 @@ mkErrorReport rea ctxt tcl_env (Report important relevant_bindings valid_subs)
(vcat $ relevant_bindings ++ valid_subs)
}
+-- This version does not include the context
+mkErrorReportNC :: DiagnosticReason
+ -> TcLclEnv
+ -> Report
+ -> TcM (MsgEnvelope DiagnosticMessage)
+mkErrorReportNC rea tcl_env (Report important relevant_bindings valid_subs)
+ = mkDecoratedSDocAt rea (RealSrcSpan (tcl_loc tcl_env) Nothing)
+ (vcat important)
+ O.empty
+ (vcat $ relevant_bindings ++ valid_subs)
+
type UserGiven = Implication
getUserGivens :: ReportErrCtxt -> [UserGiven]
@@ -1084,13 +1093,12 @@ solve it.
************************************************************************
-}
-mkIrredErr :: DiagnosticReason -> ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage)
-mkIrredErr reason ctxt cts
+mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM Report
+mkIrredErr ctxt cts
= do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1
; let orig = ctOrigin ct1
msg = couldNotDeduce (getUserGivens ctxt) (map ctPred cts, orig)
- ; mkErrorMsgFromCt reason ctxt ct1 $
- msg `mappend` mk_relevant_bindings binds_msg }
+ ; return $ msg `mappend` mk_relevant_bindings binds_msg }
where
(ct1:_) = cts
@@ -1140,14 +1148,15 @@ mkHoleError _tidy_simples ctxt hole@(Hole { hole_occ = occ
; imp_info <- getImports
; curr_mod <- getModule
; hpt <- getHpt
- ; let mk_err rea = do
- mkDecoratedSDocAt rea (RealSrcSpan (tcl_loc lcl_env) Nothing)
- out_of_scope_msg O.empty
- (unknownNameSuggestions dflags hpt curr_mod rdr_env
- (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ))
-
- ; maybeAddDeferredBindings ctxt hole mk_err
- ; whenNotDeferring (cec_out_of_scope_holes ctxt) mk_err
+ ; let err = important out_of_scope_msg `mappend`
+ (mk_relevant_bindings $
+ unknownNameSuggestions dflags hpt curr_mod rdr_env
+ (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
+ -- Use NC variant: the context is generally not helpful here
}
where
herald | isDataOcc occ = text "Data constructor not in scope:"
@@ -1180,18 +1189,15 @@ mkHoleError tidy_simples ctxt hole@(Hole { hole_occ = occ
then validHoleFits ctxt tidy_simples hole
else return (ctxt, empty)
- ; let mk_err rea =
- mkErrorReport rea ctxt lcl_env $
- important hole_msg `mappend`
- mk_relevant_bindings (binds_msg $$ constraints_msg) `mappend`
- valid_hole_fits sub_msg
+ ; let err = important hole_msg `mappend`
+ mk_relevant_bindings (binds_msg $$ constraints_msg) `mappend`
+ valid_hole_fits sub_msg
- ; maybeAddDeferredBindings ctxt hole mk_err
+ ; maybeAddDeferredBindings ctxt hole err
; let holes | ExprHole _ <- sort = cec_expr_holes ctxt
| otherwise = cec_type_holes ctxt
- ; whenNotDeferring holes mk_err
-
+ ; for holes $ \ rea -> mkErrorReport rea ctxt lcl_env err
}
where
@@ -1250,22 +1256,6 @@ mkHoleError tidy_simples ctxt hole@(Hole { hole_occ = occ
quotes (ppr tv) <+> text "is a coercion variable"
--- | Similar in spirit to 'whenIsJust', but the action returns a value of type @Maybe b@.
-whenNotDeferring :: Monad m => Maybe a -> (a -> m b) -> m (Maybe b)
-whenNotDeferring = flip traverse
-
-{- Note [Adding deferred bindings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-When working with typed holes we have to deal with the case where
-we want holes to be reported as warnings to users during compile time but
-as errors during runtime. Therefore, we have to call 'maybeAddDeferredBindings'
-with a function which is able to override the 'DiagnosticReason' of a 'DiagnosticMessage',
-so that the correct 'Severity' can be computed out of that later on.
-
--}
-
-
{- Note [Adding deferred bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1282,18 +1272,16 @@ so that the correct 'Severity' can be computed out of that later on.
-- See Note [Adding deferred bindings].
maybeAddDeferredBindings :: ReportErrCtxt
-> Hole
- -> (DiagnosticReason -> TcM (MsgEnvelope DiagnosticMessage))
+ -> Report
-> TcM ()
-maybeAddDeferredBindings ctxt hole mk_err = do
+maybeAddDeferredBindings ctxt hole report = do
case hole_sort hole of
ExprHole (HER ref ref_ty _) -> do
-- Only add bindings for holes in expressions
-- not for holes in partial type signatures
-- cf. addDeferredBinding
when (deferringAnyBindings ctxt) $ do
- dflags <- getDynFlags
- err <- mk_err ErrorWithoutFlag
- let err_tm = mkErrorTerm dflags ref_ty err
+ err_tm <- mkErrorTerm ctxt (hole_loc hole) ref_ty report
-- NB: ref_ty, not hole_ty. hole_ty might be rewritten.
-- See Note [Holes] in GHC.Tc.Types.Constraint
writeMutVar ref err_tm
@@ -1334,8 +1322,8 @@ givenConstraintsMsg ctxt =
2 (vcat $ map pprConstraint constraints)
----------------
-mkIPErr :: DiagnosticReason -> ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage)
-mkIPErr reason ctxt cts
+mkIPErr :: ReportErrCtxt -> [Ct] -> TcM Report
+mkIPErr ctxt cts
= do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1
; let orig = ctOrigin ct1
preds = map ctPred cts
@@ -1347,8 +1335,7 @@ mkIPErr reason ctxt cts
| otherwise
= couldNotDeduce givens (preds, orig)
- ; mkErrorMsgFromCt reason ctxt ct1 $
- msg `mappend` mk_relevant_bindings binds_msg }
+ ; return $ msg `mappend` mk_relevant_bindings binds_msg }
where
(ct1:_) = cts
@@ -1411,12 +1398,12 @@ any more. So we don't assert that it is.
-- Don't have multiple equality errors from the same location
-- E.g. (Int,Bool) ~ (Bool,Int) one error will do!
-mkEqErr :: DiagnosticReason -> ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage)
-mkEqErr reason ctxt (ct:_) = mkEqErr1 reason ctxt ct
-mkEqErr _ _ [] = panic "mkEqErr"
+mkEqErr :: ReportErrCtxt -> [Ct] -> TcM Report
+mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct
+mkEqErr _ [] = panic "mkEqErr"
-mkEqErr1 :: DiagnosticReason -> ReportErrCtxt -> Ct -> TcM (MsgEnvelope DiagnosticMessage)
-mkEqErr1 reason ctxt ct -- Wanted or derived;
+mkEqErr1 :: ReportErrCtxt -> Ct -> TcM Report
+mkEqErr1 ctxt ct -- Wanted or derived;
-- givens handled in mkGivenErrorReporter
= do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
; rdr_env <- getGlobalRdrEnv
@@ -1424,11 +1411,10 @@ mkEqErr1 reason ctxt ct -- Wanted or derived;
; let coercible_msg = case ctEqRel ct of
NomEq -> empty
ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2
- ; dflags <- getDynFlags
; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctOrigin ct))
; let report = mconcat [ important coercible_msg
, mk_relevant_bindings binds_msg]
- ; mkEqErr_help reason dflags ctxt report ct ty1 ty2 }
+ ; mkEqErr_help ctxt report ct ty1 ty2 }
where
(ty1, ty2) = getEqPredTys (ctPred ct)
@@ -1479,78 +1465,78 @@ mkCoercibleExplanation rdr_env fam_envs ty1 ty2
| otherwise
= False
-mkEqErr_help :: DiagnosticReason
- -> DynFlags -> ReportErrCtxt -> Report
+mkEqErr_help :: ReportErrCtxt -> Report
-> Ct
- -> TcType -> TcType -> TcM (MsgEnvelope DiagnosticMessage)
-mkEqErr_help reason dflags ctxt report ct ty1 ty2
+ -> TcType -> TcType -> TcM Report
+mkEqErr_help ctxt report ct ty1 ty2
| Just (tv1, _) <- tcGetCastedTyVar_maybe ty1
- = mkTyVarEqErr reason dflags ctxt report ct tv1 ty2
+ = mkTyVarEqErr ctxt report ct tv1 ty2
| Just (tv2, _) <- tcGetCastedTyVar_maybe ty2
- = mkTyVarEqErr reason dflags ctxt report ct tv2 ty1
+ = mkTyVarEqErr ctxt report ct tv2 ty1
| otherwise
- = reportEqErr reason ctxt report ct ty1 ty2
+ = return $ reportEqErr ctxt report ct ty1 ty2
-reportEqErr :: DiagnosticReason -> ReportErrCtxt -> Report
+reportEqErr :: ReportErrCtxt -> Report
-> Ct
- -> TcType -> TcType -> TcM (MsgEnvelope DiagnosticMessage)
-reportEqErr reason ctxt report ct ty1 ty2
- = mkErrorMsgFromCt reason ctxt ct (mconcat [misMatch, report, eqInfo])
+ -> TcType -> TcType -> Report
+reportEqErr ctxt report ct ty1 ty2
+ = mconcat [misMatch, report, eqInfo]
where
misMatch = misMatchOrCND False ctxt ct ty1 ty2
eqInfo = mkEqInfoMsg ct ty1 ty2
-mkTyVarEqErr, mkTyVarEqErr'
- :: DiagnosticReason
- -> DynFlags -> ReportErrCtxt -> Report -> Ct
- -> TcTyVar -> TcType -> TcM (MsgEnvelope DiagnosticMessage)
+mkTyVarEqErr :: ReportErrCtxt -> Report -> Ct
+ -> TcTyVar -> TcType -> TcM Report
-- tv1 and ty2 are already tidied
-mkTyVarEqErr reason dflags ctxt report ct tv1 ty2
+mkTyVarEqErr ctxt report ct tv1 ty2
= do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr ty2)
- ; mkTyVarEqErr' reason dflags ctxt report ct tv1 ty2 }
+ ; dflags <- getDynFlags
+ ; return $ mkTyVarEqErr' dflags ctxt report ct tv1 ty2 }
-mkTyVarEqErr' reason dflags ctxt report ct tv1 ty2
+mkTyVarEqErr' :: DynFlags -> ReportErrCtxt -> Report -> Ct
+ -> TcTyVar -> TcType -> Report
+mkTyVarEqErr' dflags ctxt report ct tv1 ty2
| isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar; we would have
-- swapped in Solver.Canonical.canEqTyVarHomo
|| isTyVarTyVar tv1 && not (isTyVarTy ty2)
|| ctEqRel ct == ReprEq
-- The cases below don't really apply to ReprEq (except occurs check)
- = mkErrorMsgFromCt reason ctxt ct $ mconcat
- [ headline_msg
- , extraTyVarEqInfo ctxt tv1 ty2
- , suggestAddSig ctxt ty1 ty2
- , report
- ]
+ = mconcat [ headline_msg
+ , extraTyVarEqInfo ctxt tv1 ty2
+ , suggestAddSig ctxt ty1 ty2
+ , report
+ ]
| CTE_Occurs <- occ_check_expand
-- We report an "occurs check" even for a ~ F t a, where F is a type
-- function; it's not insoluble (because in principle F could reduce)
-- but we have certainly been unable to solve it
-- See Note [Occurs check error] in GHC.Tc.Solver.Canonical
- = do { let extra2 = mkEqInfoMsg ct ty1 ty2
-
- interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $
- filter isTyVar $
- fvVarList $
- tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2
- extra3 = mk_relevant_bindings $
- ppWhen (not (null interesting_tyvars)) $
- hang (text "Type variable kinds:") 2 $
- vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt))
- interesting_tyvars)
-
- tyvar_binding tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv)
- ; mkErrorMsgFromCt reason ctxt ct $
- mconcat [headline_msg, extra2, extra3, report] }
+ = let extra2 = mkEqInfoMsg ct ty1 ty2
+
+ interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $
+ filter isTyVar $
+ fvVarList $
+ tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2
+ extra3 = mk_relevant_bindings $
+ ppWhen (not (null interesting_tyvars)) $
+ hang (text "Type variable kinds:") 2 $
+ vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt))
+ interesting_tyvars)
+
+ tyvar_binding tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv)
+ in
+ mconcat [headline_msg, extra2, extra3, report]
| CTE_Bad <- occ_check_expand
- = do { let msg = vcat [ text "Cannot instantiate unification variable"
- <+> quotes (ppr tv1)
- , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2) ]
+ = let msg = vcat [ text "Cannot instantiate unification variable"
+ <+> quotes (ppr tv1)
+ , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2) ]
+ in
-- Unlike the other reports, this discards the old 'report_important'
-- instead of augmenting it. This is because the details are not likely
-- to be helpful since this is just an unimplemented feature.
- ; mkErrorMsgFromCt reason ctxt ct $ mconcat [ headline_msg, important msg, report ] }
+ mconcat [ headline_msg, important msg, report ]
-- If the immediately-enclosing implication has 'tv' a skolem, and
-- we know by now its an InferSkol kind of skolem, then presumably
@@ -1559,35 +1545,35 @@ mkTyVarEqErr' reason dflags ctxt report ct tv1 ty2
| (implic:_) <- cec_encl ctxt
, Implic { ic_skols = skols } <- implic
, tv1 `elem` skols
- = mkErrorMsgFromCt reason ctxt ct $ mconcat
- [ misMatchMsg ctxt ct ty1 ty2
- , extraTyVarEqInfo ctxt tv1 ty2
- , report
- ]
+ = mconcat [ misMatchMsg ctxt ct ty1 ty2
+ , extraTyVarEqInfo ctxt tv1 ty2
+ , report
+ ]
-- Check for skolem escape
| (implic:_) <- cec_encl ctxt -- Get the innermost context
, Implic { ic_skols = skols, ic_info = skol_info } <- implic
, let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols
, not (null esc_skols)
- = do { let msg = misMatchMsg ctxt ct ty1 ty2
- esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols
- <+> pprQuotedList esc_skols
- , text "would escape" <+>
- if isSingleton esc_skols then text "its scope"
- else text "their scope" ]
- tv_extra = important $
- vcat [ nest 2 $ esc_doc
- , sep [ (if isSingleton esc_skols
- then text "This (rigid, skolem)" <+>
- what <+> text "variable is"
- else text "These (rigid, skolem)" <+>
- what <+> text "variables are")
- <+> text "bound by"
- , nest 2 $ ppr skol_info
- , nest 2 $ text "at" <+>
- ppr (tcl_loc (ic_env implic)) ] ]
- ; mkErrorMsgFromCt reason ctxt ct (mconcat [msg, tv_extra, report]) }
+ = let msg = misMatchMsg ctxt ct ty1 ty2
+ esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols
+ <+> pprQuotedList esc_skols
+ , text "would escape" <+>
+ if isSingleton esc_skols then text "its scope"
+ else text "their scope" ]
+ tv_extra = important $
+ vcat [ nest 2 $ esc_doc
+ , sep [ (if isSingleton esc_skols
+ then text "This (rigid, skolem)" <+>
+ what <+> text "variable is"
+ else text "These (rigid, skolem)" <+>
+ what <+> text "variables are")
+ <+> text "bound by"
+ , nest 2 $ ppr skol_info
+ , nest 2 $ text "at" <+>
+ ppr (tcl_loc (ic_env implic)) ] ]
+ in
+ mconcat [msg, tv_extra, report]
-- Nastiest case: attempt to unify an untouchable variable
-- So tv is a meta tyvar (or started that way before we
@@ -1598,21 +1584,21 @@ mkTyVarEqErr' reason dflags ctxt report ct tv1 ty2
, Implic { ic_given = given, ic_tclvl = lvl, ic_info = skol_info } <- implic
= ASSERT2( not (isTouchableMetaTyVar lvl tv1)
, ppr tv1 $$ ppr lvl ) -- See Note [Error messages for untouchables]
- do { let msg = misMatchMsg ctxt ct ty1 ty2
- tclvl_extra = important $
- nest 2 $
- sep [ quotes (ppr tv1) <+> text "is untouchable"
- , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given
- , nest 2 $ text "bound by" <+> ppr skol_info
- , nest 2 $ text "at" <+>
- ppr (tcl_loc (ic_env implic)) ]
- tv_extra = extraTyVarEqInfo ctxt tv1 ty2
- add_sig = suggestAddSig ctxt ty1 ty2
- ; mkErrorMsgFromCt reason ctxt ct $ mconcat
- [msg, tclvl_extra, tv_extra, add_sig, report] }
+ let msg = misMatchMsg ctxt ct ty1 ty2
+ tclvl_extra = important $
+ nest 2 $
+ sep [ quotes (ppr tv1) <+> text "is untouchable"
+ , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given
+ , nest 2 $ text "bound by" <+> ppr skol_info
+ , nest 2 $ text "at" <+>
+ ppr (tcl_loc (ic_env implic)) ]
+ tv_extra = extraTyVarEqInfo ctxt tv1 ty2
+ add_sig = suggestAddSig ctxt ty1 ty2
+ in
+ mconcat [msg, tclvl_extra, tv_extra, add_sig, report]
| otherwise
- = reportEqErr reason ctxt report ct (mkTyVarTy tv1) ty2
+ = reportEqErr ctxt report ct (mkTyVarTy tv1) ty2
-- This *can* happen (#6123, and test T2627b)
-- Consider an ambiguous top-level constraint (a ~ F a)
-- Not an occurs check, because F is a type function.
@@ -1703,10 +1689,9 @@ pp_givens givens
-- always be another unsolved wanted around, which will ordinarily suppress
-- this message. But this can still be printed out with -fdefer-type-errors
-- (sigh), so we must produce a message.
-mkBlockedEqErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage)
-mkBlockedEqErr ctxt (ct:_) = mkErrorMsgFromCt ErrorWithoutFlag ctxt ct report
+mkBlockedEqErr :: ReportErrCtxt -> [Ct] -> TcM Report
+mkBlockedEqErr _ (ct:_) = return $ important msg
where
- report = important msg
msg = vcat [ hang (text "Cannot use equality for substitution:")
2 (ppr (ctPred ct))
, text "Doing so would be ill-kinded." ]
@@ -2310,12 +2295,11 @@ Warn of loopy local equalities that were dropped.
************************************************************************
-}
-mkDictErr :: DiagnosticReason -> ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage)
-mkDictErr reason ctxt cts
+mkDictErr :: ReportErrCtxt -> [Ct] -> TcM Report
+mkDictErr ctxt cts
= ASSERT( not (null cts) )
do { inst_envs <- tcGetInstEnvs
- ; let (ct1:_) = cts -- ct1 just for its location
- min_cts = elim_superclasses cts
+ ; let min_cts = elim_superclasses cts
lookups = map (lookup_cls_inst inst_envs) min_cts
(no_inst_cts, overlap_cts) = partition is_no_inst lookups
@@ -2324,8 +2308,8 @@ mkDictErr reason ctxt cts
-- But we report only one of them (hence 'head') because they all
-- have the same source-location origin, to try avoid a cascade
-- of error from one location
- ; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts))
- ; mkErrorMsgFromCt reason ctxt ct1 (important err) }
+ ; err <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts))
+ ; return $ important err }
where
no_givens = null (getUserGivens ctxt)
@@ -2347,20 +2331,20 @@ mkDictErr reason ctxt cts
elim_superclasses cts = mkMinimalBySCs ctPred cts
mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult)
- -> TcM (ReportErrCtxt, SDoc)
+ -> TcM SDoc
-- Report an overlap error if this class constraint results
-- from an overlap (returning Left clas), otherwise return (Right pred)
mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_overlapped))
| null matches -- No matches but perhaps several unifiers
- = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
+ = do { (_, binds_msg, ct) <- relevantBindings True ctxt ct
; candidate_insts <- get_candidate_instances
- ; return (ctxt, cannot_resolve_msg ct candidate_insts binds_msg) }
+ ; return (cannot_resolve_msg ct candidate_insts binds_msg) }
| null unsafe_overlapped -- Some matches => overlap errors
- = return (ctxt, overlap_msg)
+ = return overlap_msg
| otherwise
- = return (ctxt, safe_haskell_msg)
+ = return safe_haskell_msg
where
orig = ctOrigin ct
pred = ctPred ct