summaryrefslogtreecommitdiff
path: root/compiler/GHC/Tc/Errors.hs
diff options
context:
space:
mode:
authorRichard Eisenberg <rae@richarde.dev>2022-02-18 23:29:52 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2022-02-23 08:16:07 -0500
commita599abbad939820c666ced00ae9eb33706a4f360 (patch)
tree7b3811972a50da9e81018056cdcdeef158bc22e3 /compiler/GHC/Tc/Errors.hs
parent558c7d554b9724abfaa2bcc1f42050e67b36a988 (diff)
downloadhaskell-a599abbad939820c666ced00ae9eb33706a4f360.tar.gz
Kill derived constraints
Co-authored by: Sam Derbyshire Previously, GHC had three flavours of constraint: Wanted, Given, and Derived. This removes Derived constraints. Though serving a number of purposes, the most important role of Derived constraints was to enable better error messages. This job has been taken over by the new RewriterSets, as explained in Note [Wanteds rewrite wanteds] in GHC.Tc.Types.Constraint. Other knock-on effects: - Various new Notes as I learned about under-described bits of GHC - A reshuffling around the AST for implicit-parameter bindings, with better integration with TTG. - Various improvements around fundeps. These were caused by the fact that, previously, fundep constraints were all Derived, and Derived constraints would get dropped. Thus, an unsolved Derived didn't stop compilation. Without Derived, this is no longer possible, and so we have to be considerably more careful around fundeps. - A nice little refactoring in GHC.Tc.Errors to center the work on a new datatype called ErrorItem. Constraints are converted into ErrorItems at the start of processing, and this allows for a little preprocessing before the main classification. - This commit also cleans up the behavior in generalisation around functional dependencies. Now, if a variable is determined by functional dependencies, it will not be quantified. This change is user facing, but it should trim down GHC's strange behavior around fundeps. - Previously, reportWanteds did quite a bit of work, even on an empty WantedConstraints. This commit adds a fast path. - Now, GHC will unconditionally re-simplify constraints during quantification. See Note [Unconditionally resimplify constraints when quantifying], in GHC.Tc.Solver. Close #18398. Close #18406. Solve the fundep-related non-confluence in #18851. Close #19131. Close #19137. Close #20922. Close #20668. Close #19665. ------------------------- Metric Decrease: LargeRecord T9872b T9872b_defer T9872d TcPlugin_RewritePerf -------------------------
Diffstat (limited to 'compiler/GHC/Tc/Errors.hs')
-rw-r--r--compiler/GHC/Tc/Errors.hs853
1 files changed, 478 insertions, 375 deletions
diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs
index a833e76661..b71a6b1dd4 100644
--- a/compiler/GHC/Tc/Errors.hs
+++ b/compiler/GHC/Tc/Errors.hs
@@ -3,6 +3,7 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
@@ -13,8 +14,6 @@ module GHC.Tc.Errors(
reportUnsolved, reportAllUnsolved, warnAllUnsolved,
warnDefaulting,
- solverDepthErrorTcS,
-
-- * GHC API helper functions
solverReportMsg_ExpectedActuals,
solverReportInfo_ExpectedActuals
@@ -92,7 +91,7 @@ import Data.List.NonEmpty ( NonEmpty(..), (<|) )
import qualified Data.List.NonEmpty as NE ( map, reverse )
import Data.List ( sortBy )
import Data.Ord ( comparing )
-
+import qualified Data.Semigroup as S
{-
************************************************************************
@@ -464,20 +463,73 @@ But without the context we won't find beta := Zero.
This only matters in instance declarations..
-}
+-- | Should we completely ignore this constraint in error reporting?
+-- It *must* be the case that any constraint for which this returns True
+-- somehow causes an error to be reported elsewhere.
+-- See Note [Constraints to ignore].
+ignoreConstraint :: Ct -> Bool
+ignoreConstraint ct
+ | AssocFamPatOrigin <- ctOrigin ct
+ = True
+ | otherwise
+ = False
+
+-- | Makes an error item from a constraint, calculating whether or not
+-- the item should be suppressed. See Note [Wanteds rewrite Wanteds]
+-- in GHC.Tc.Types.Constraint. Returns Nothing if we should just ignore
+-- a constraint. See Note [Constraints to ignore].
+mkErrorItem :: Ct -> TcM (Maybe ErrorItem)
+mkErrorItem ct
+ | ignoreConstraint ct
+ = do { traceTc "Ignoring constraint:" (ppr ct)
+ ; return Nothing } -- See Note [Constraints to ignore]
+
+ | otherwise
+ = do { let loc = ctLoc ct
+ flav = ctFlavour ct
+
+ ; (suppress, m_evdest) <- case ctEvidence ct of
+ CtGiven {} -> return (False, Nothing)
+ CtWanted { ctev_rewriters = rewriters, ctev_dest = dest }
+ -> do { supp <- anyUnfilledCoercionHoles rewriters
+ ; return (supp, Just dest) }
+
+ ; let m_reason = case ct of CIrredCan { cc_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 }}
+
+----------------------------------------------------------------
reportWanteds :: SolverReportErrCtxt -> TcLevel -> WantedConstraints -> TcM ()
-reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics
- , wc_holes = holes })
- = do { traceTc "reportWanteds" (vcat [ text "Simples =" <+> ppr simples
- , text "Suppress =" <+> ppr (cec_suppress ctxt)
- , text "tidy_cts =" <+> ppr tidy_cts
- , text "tidy_holes = " <+> ppr tidy_holes ])
+reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics
+ , wc_holes = holes })
+ | isEmptyWC wc = traceTc "reportWanteds empty WC" empty
+ | otherwise
+ = do { tidy_items <- mapMaybeM mkErrorItem tidy_cts
+ ; traceTc "reportWanteds 1" (vcat [ text "Simples =" <+> ppr simples
+ , text "Suppress =" <+> ppr (cec_suppress ctxt)
+ , text "tidy_cts =" <+> ppr tidy_cts
+ , text "tidy_items =" <+> ppr tidy_items
+ , text "tidy_holes =" <+> ppr tidy_holes ])
+
+ -- This check makes sure that we aren't suppressing the only error that will
+ -- actually stop compilation
+ ; massert $
+ null simples || -- no errors to report here
+ any ignoreConstraint simples || -- one error is ignorable (is reported elsewhere)
+ not (all ei_suppress tidy_items) -- not all error are suppressed
-- First, deal with any out-of-scope errors:
; let (out_of_scope, other_holes) = partition isOutOfScopeHole tidy_holes
-- don't suppress out-of-scope errors
ctxt_for_scope_errs = ctxt { cec_suppress = False }
; (_, no_out_of_scope) <- askNoErrs $
- reportHoles tidy_cts ctxt_for_scope_errs out_of_scope
+ reportHoles tidy_items ctxt_for_scope_errs out_of_scope
-- Next, deal with things that are utterly wrong
-- Like Int ~ Bool (incl nullary TyCons)
@@ -485,57 +537,71 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics
-- These /ones/ are not suppressed by the incoming context
-- (but will be by out-of-scope errors)
; let ctxt_for_insols = ctxt { cec_suppress = not no_out_of_scope }
- ; reportHoles tidy_cts ctxt_for_insols other_holes
+ ; reportHoles tidy_items ctxt_for_insols other_holes
-- holes never suppress
- ; (ctxt1, cts1) <- tryReporters ctxt_for_insols report1 tidy_cts
+ -- See Note [Suppressing confusing errors]
+ ; let (suppressed_items, items0) = partition suppress tidy_items
+ ; traceTc "reportWanteds suppressed:" (ppr suppressed_items)
+ ; (ctxt1, items1) <- tryReporters ctxt_for_insols report1 items0
-- Now all the other constraints. We suppress errors here if
-- any of the first batch failed, or if the enclosing context
-- says to suppress
- ; let ctxt2 = ctxt { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 }
- ; (_, leftovers) <- tryReporters ctxt2 report2 cts1
+ ; let ctxt2 = ctxt1 { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 }
+ ; (ctxt3, leftovers) <- tryReporters ctxt2 report2 items1
; massertPpr (null leftovers)
(text "The following unsolved Wanted constraints \
\have not been reported to the user:"
$$ ppr leftovers)
- -- All the Derived ones have been filtered out of simples
- -- by the constraint solver. This is ok; we don't want
- -- to report unsolved Derived goals as errors
- -- See Note [Do not report derived but soluble errors]
-
- ; mapBagM_ (reportImplic ctxt2) implics }
+ ; mapBagM_ (reportImplic ctxt2) implics
-- NB ctxt2: don't suppress inner insolubles if there's only a
-- wanted insoluble here; but do suppress inner insolubles
-- if there's a *given* insoluble here (= inaccessible code)
+
+ -- Only now, if there are no errors, do we report suppressed ones
+ -- See Note [Suppressing confusing errors]
+ -- We don't need to update the context further because of the
+ -- whenNoErrs guard
+ ; whenNoErrs $
+ do { (_, more_leftovers) <- tryReporters ctxt3 report3 suppressed_items
+ ; massertPpr (null more_leftovers) (ppr more_leftovers) } }
where
- env = cec_tidy ctxt
+ env = cec_tidy ctxt
tidy_cts = bagToList (mapBag (tidyCt env) simples)
tidy_holes = bagToList (mapBag (tidyHole env) holes)
+ -- See Note [Suppressing confusing errors]
+ suppress :: ErrorItem -> Bool
+ suppress item
+ | Wanted <- ei_flavour item
+ = is_ww_fundep_item item
+ | otherwise
+ = False
+
-- report1: ones that should *not* be suppressed by
-- an insoluble somewhere else in the tree
-- It's crucial that anything that is considered insoluble
-- (see GHC.Tc.Utils.insolublWantedCt) is caught here, otherwise
-- we might suppress its error message, and proceed on past
-- type checking to get a Lint error later
- report1 = [ ("custom_error", unblocked is_user_type_error, True, mkUserTypeErrorReporter)
+ report1 = [ ("custom_error", is_user_type_error, True, mkUserTypeErrorReporter)
, given_eq_spec
- , ("insoluble2", unblocked utterly_wrong, True, mkGroupReporter mkEqErr)
- , ("skolem eq1", unblocked very_wrong, True, mkSkolReporter)
- , ("skolem eq2", unblocked skolem_eq, True, mkSkolReporter)
- , ("non-tv eq", unblocked non_tv_eq, True, mkSkolReporter)
+ , ("insoluble2", utterly_wrong, True, mkGroupReporter mkEqErr)
+ , ("skolem eq1", very_wrong, True, mkSkolReporter)
+ , ("skolem eq2", skolem_eq, True, mkSkolReporter)
+ , ("non-tv eq", non_tv_eq, True, mkSkolReporter)
-- The only remaining equalities are alpha ~ ty,
-- where alpha is untouchable; and representational equalities
-- Prefer homogeneous equalities over hetero, because the
-- former might be holding up the latter.
-- See Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical
- , ("Homo eqs", unblocked is_homo_equality, True, mkGroupReporter mkEqErr)
- , ("Other eqs", unblocked is_equality, True, mkGroupReporter mkEqErr)
- , ("Blocked eqs", is_equality, False, mkSuppressReporter mkBlockedEqErr)]
+ , ("Homo eqs", is_homo_equality, True, mkGroupReporter mkEqErr)
+ , ("Other eqs", is_equality, True, mkGroupReporter mkEqErr)
+ ]
-- report2: we suppress these if there are insolubles elsewhere in the tree
report2 = [ ("Implicit params", is_ip, False, mkGroupReporter mkIPErr)
@@ -543,17 +609,17 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics
, ("FixedRuntimeRep", is_FRR, False, mkGroupReporter mkFRRErr)
, ("Dicts", is_dict, False, mkGroupReporter mkDictErr) ]
- -- also checks to make sure the constraint isn't HoleBlockerReason
- -- See TcCanonical Note [Equalities with incompatible kinds], (4)
- unblocked :: (Ct -> Pred -> Bool) -> Ct -> Pred -> Bool
- unblocked _ (CIrredCan { cc_reason = HoleBlockerReason {}}) _ = False
- unblocked checker ct pred = checker ct pred
+ -- report3: suppressed errors should be reported as categorized by either report1
+ -- or report2. Keep this in sync with the suppress function above
+ report3 = [ ("wanted/wanted fundeps", is_ww_fundep, True, mkGroupReporter mkEqErr)
+ ]
-- rigid_nom_eq, rigid_nom_tv_eq,
- is_dict, is_equality, is_ip, is_FRR, is_irred :: Ct -> Pred -> Bool
+ is_dict, is_equality, is_ip, is_FRR, is_irred :: ErrorItem -> Pred -> Bool
- is_given_eq ct pred
- | EqPred {} <- pred = arisesFromGivens ct
+ is_given_eq item pred
+ | Given <- ei_flavour item
+ , EqPred {} <- pred = True
| otherwise = False
-- I think all given residuals are equalities
@@ -573,7 +639,7 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics
non_tv_eq _ (EqPred NomEq ty1 _) = not (isTyVarTy ty1)
non_tv_eq _ _ = False
- is_user_type_error ct _ = isUserTypeErrorCt ct
+ is_user_type_error item _ = isUserTypeError (errorItemPred item)
is_homo_equality _ (EqPred _ ty1 ty2) = tcTypeKind ty1 `tcEqType` tcTypeKind ty2
is_homo_equality _ _ = False
@@ -587,8 +653,8 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics
is_ip _ (ClassPred cls _) = isIPClass cls
is_ip _ _ = False
- is_FRR ct (SpecialPred ConcretePrimPred _)
- | FixedRuntimeRepOrigin {} <- ctOrigin ct
+ is_FRR item (SpecialPred ConcretePrimPred _)
+ | FixedRuntimeRepOrigin {} <- errorItemOrigin item
= True
is_FRR _ _
= False
@@ -596,8 +662,12 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics
is_irred _ (IrredPred {}) = True
is_irred _ _ = False
+ -- See situation (1) of Note [Suppressing confusing errors]
+ is_ww_fundep item _ = is_ww_fundep_item item
+ is_ww_fundep_item = isWantedWantedFunDepOrigin . errorItemOrigin
+
given_eq_spec -- See Note [Given errors]
- | has_gadt_match (cec_encl ctxt)
+ | has_gadt_match_here
= ("insoluble1a", is_given_eq, True, mkGivenErrorReporter)
| otherwise
= ("insoluble1b", is_given_eq, False, ignoreErrorReporter)
@@ -608,6 +678,7 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics
-- #13446 is an example
-- See Note [Given errors]
+ has_gadt_match_here = has_gadt_match (cec_encl ctxt)
has_gadt_match [] = False
has_gadt_match (implic : implics)
| PatSkol {} <- ic_info implic
@@ -637,36 +708,119 @@ isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of
Just (tc,_) | isTypeFamilyTyCon tc -> Just tc
_ -> Nothing
+{- Note [Suppressing confusing errors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Certain errors we might encounter are potentially confusing to users.
+If there are any other errors to report, at all, we want to suppress these.
+
+Which errors (only 1 case right now):
+
+1) Errors which arise from the interaction of two Wanted fun-dep constraints.
+ Example:
+
+ class C a b | a -> b where
+ op :: a -> b -> b
+
+ foo _ = op True Nothing
+
+ bar _ = op False []
+
+ Here, we could infer
+ foo :: C Bool (Maybe a) => p -> Maybe a
+ bar :: C Bool [a] => p -> [a]
+
+ (The unused arguments suppress the monomorphism restriction.) The problem
+ is that these types can't both be correct, as they violate the functional
+ dependency. Yet reporting an error here is awkward: we must
+ non-deterministically choose either foo or bar to reject. We thus want
+ to report this problem only when there is nothing else to report.
+ See typecheck/should_fail/T13506 for an example of when to suppress
+ the error. The case above is actually accepted, because foo and bar
+ are checked separately, and thus the two fundep constraints never
+ encounter each other. It is test case typecheck/should_compile/FunDepOrigin1.
+
+ This case applies only when both fundeps are *Wanted* fundeps; when
+ both are givens, the error represents unreachable code. For
+ a Given/Wanted case, see #9612.
+
+Mechanism:
+
+We use the `suppress` function within reportWanteds to filter out these two
+cases, then report all other errors. Lastly, we return to these suppressed
+ones and report them only if there have been no errors so far.
+
+Note [Constraints to ignore]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Some constraints are meant only to aid the solver by unification; a failure
+to solve them is not necessarily an error to report to the user. It is critical
+that compilation is aborted elsewhere if there are any ignored constraints here;
+they will remain unfilled, and might have been used to rewrite another constraint.
+
+Currently, the constraints to ignore are:
+
+1) Constraints generated in order to unify associated type instance parameters
+ with class parameters. Here are two illustrative examples:
+
+ class C (a :: k) where
+ type F (b :: k)
+
+ instance C True where
+ type F a = Int
+
+ instance C Left where
+ type F (Left :: a -> Either a b) = Bool
+
+ In the first instance, we want to infer that `a` has type Bool. So we emit
+ a constraint unifying kappa (the guessed type of `a`) with Bool. All is well.
+
+ In the second instance, we process the associated type instance only
+ after fixing the quantified type variables of the class instance. We thus
+ have skolems a1 and b1 such that the class instance is for (Left :: a1 -> Either a1 b1).
+ Unifying a1 and b1 with a and b in the type instance will fail, but harmlessly so.
+ checkConsistentFamInst checks for this, and will fail if anything has gone
+ awry. Really the equality constraints emitted are just meant as an aid, not
+ a requirement. This is test case T13972.
+
+ We detect this case by looking for an origin of AssocFamPatOrigin; constraints
+ with this origin are dropped entirely during error message reporting.
+
+ If there is any trouble, checkValidFamInst bleats, aborting compilation.
+
+-}
+
+
+
--------------------------------------------
-- Reporters
--------------------------------------------
type Reporter
- = SolverReportErrCtxt -> [Ct] -> TcM ()
+ = SolverReportErrCtxt -> [ErrorItem] -> TcM ()
type ReporterSpec
- = ( String -- Name
- , Ct -> Pred -> Bool -- Pick these ones
- , Bool -- True <=> suppress subsequent reporters
- , Reporter) -- The reporter itself
+ = ( String -- Name
+ , ErrorItem -> Pred -> Bool -- Pick these ones
+ , Bool -- True <=> suppress subsequent reporters
+ , Reporter) -- The reporter itself
mkSkolReporter :: Reporter
-- Suppress duplicates with either the same LHS, or same location
-mkSkolReporter ctxt cts
- = mapM_ (reportGroup mkEqErr ctxt) (group cts)
+-- Pre-condition: all items are equalities
+mkSkolReporter ctxt items
+ = mapM_ (reportGroup mkEqErr ctxt) (group items)
where
group [] = []
- group (ct:cts) = (ct : yeses) : group noes
+ group (item:items) = (item : yeses) : group noes
where
- (yeses, noes) = partition (group_with ct) cts
+ (yeses, noes) = partition (group_with item) items
- group_with ct1 ct2
- | EQ <- cmp_loc ct1 ct2 = True
- | eq_lhs_type ct1 ct2 = True
- | otherwise = False
+ group_with item1 item2
+ | EQ <- cmp_loc item1 item2 = True
+ | eq_lhs_type item1 item2 = True
+ | otherwise = False
-reportHoles :: [Ct] -- other (tidied) constraints
+reportHoles :: [ErrorItem] -- other (tidied) constraints
-> SolverReportErrCtxt -> [Hole] -> TcM ()
-reportHoles tidy_cts ctxt holes
+reportHoles tidy_items ctxt holes
= do
diag_opts <- initDiagOpts <$> getDynFlags
let severity = diagReasonSeverity diag_opts (cec_type_holes ctxt)
@@ -675,7 +829,7 @@ reportHoles tidy_cts ctxt holes
-- because otherwise types will be zonked and tidied many times over.
(tidy_env', lcl_name_cache) <- zonkTidyTcLclEnvs (cec_tidy ctxt) (map (ctl_env . hole_loc) holes')
let ctxt' = ctxt { cec_tidy = tidy_env' }
- forM_ holes' $ \hole -> do { msg <- mkHoleError lcl_name_cache tidy_cts ctxt' hole
+ forM_ holes' $ \hole -> do { msg <- mkHoleError lcl_name_cache tidy_items ctxt' hole
; reportDiagnostic msg }
keepThisHole :: Severity -> Hole -> Bool
@@ -734,42 +888,43 @@ machinery, in cases where it is definitely going to be a no-op.
mkUserTypeErrorReporter :: Reporter
mkUserTypeErrorReporter ctxt
- = mapM_ $ \ct -> do { let err = important ctxt $ mkUserTypeError ct
- ; maybeReportError ctxt ct err
- ; addDeferredBinding ctxt err ct }
+ = mapM_ $ \item -> do { let err = important ctxt $ mkUserTypeError item
+ ; maybeReportError ctxt [item] err
+ ; addDeferredBinding ctxt err item }
-mkUserTypeError :: Ct -> TcSolverReportMsg
-mkUserTypeError ct =
- case getUserTypeErrorMsg ct of
+mkUserTypeError :: ErrorItem -> TcSolverReportMsg
+mkUserTypeError item =
+ case getUserTypeErrorMsg (errorItemPred item) of
Just msg -> UserTypeError msg
- Nothing -> pprPanic "mkUserTypeError" (ppr ct)
+ Nothing -> pprPanic "mkUserTypeError" (ppr item)
mkGivenErrorReporter :: Reporter
-- See Note [Given errors]
-mkGivenErrorReporter ctxt cts
- = do { (ctxt, relevant_binds, ct) <- relevantBindings True ctxt ct
+mkGivenErrorReporter ctxt items
+ = do { (ctxt, relevant_binds, item) <- relevantBindings True ctxt item
; let (implic:_) = cec_encl ctxt
-- Always non-empty when mkGivenErrorReporter is called
- ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (ic_env implic))
+ loc' = setCtLocEnv (ei_loc item) (ic_env implic)
+ item' = item { ei_loc = loc' }
-- For given constraints we overwrite the env (and hence src-loc)
-- with one from the immediately-enclosing implication.
-- See Note [Inaccessible code]
- ; (eq_err_msgs, _hints) <- mkEqErr_help ctxt ct' ty1 ty2
+ ; (eq_err_msgs, _hints) <- mkEqErr_help ctxt item' ty1 ty2
-- The hints wouldn't help in this situation, so we discard them.
; let supplementary = [ SupplementaryBindings relevant_binds ]
msg = TcRnInaccessibleCode implic (NE.reverse . NE.map (SolverReportWithCtxt ctxt) $ eq_err_msgs)
- ; msg <- mkErrorReport (ctLocEnv (ctLoc ct')) msg (Just ctxt) supplementary
+ ; msg <- mkErrorReport (ctLocEnv loc') msg (Just ctxt) supplementary
; reportDiagnostic msg }
where
- (ct : _ ) = cts -- Never empty
- (ty1, ty2) = getEqPredTys (ctPred ct)
+ (item : _ ) = items -- Never empty
+ (ty1, ty2) = getEqPredTys (errorItemPred item)
ignoreErrorReporter :: Reporter
-- Discard Given errors that don't come from
-- a pattern match; maybe we should warn instead?
-ignoreErrorReporter ctxt cts
- = do { traceTc "mkGivenErrorReporter no" (ppr cts $$ ppr (cec_encl ctxt))
+ignoreErrorReporter ctxt items
+ = do { traceTc "mkGivenErrorReporter no" (ppr items $$ ppr (cec_encl ctxt))
; return () }
@@ -807,59 +962,43 @@ pattern match which binds some equality constraints. If we
find one, we report the insoluble Given.
-}
-mkGroupReporter :: (SolverReportErrCtxt -> [Ct] -> TcM SolverReport)
+mkGroupReporter :: (SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport)
-- Make error message for a group
-> Reporter -- Deal with lots of constraints
-- Group together errors from same location,
-- and report only the first (to avoid a cascade)
-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 :: (SolverReportErrCtxt -> [Ct] -> TcM SolverReport)
- -> Reporter
-mkSuppressReporter mk_err ctxt cts
- = mapM_ (suppressGroup mk_err ctxt . toList) (equivClasses cmp_loc cts)
-
-eq_lhs_type :: Ct -> Ct -> Bool
-eq_lhs_type ct1 ct2
- = case (classifyPredType (ctPred ct1), classifyPredType (ctPred ct2)) of
+mkGroupReporter mk_err ctxt items
+ = mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc items)
+
+eq_lhs_type :: ErrorItem -> ErrorItem -> Bool
+eq_lhs_type item1 item2
+ = case (classifyPredType (errorItemPred item1), classifyPredType (errorItemPred item2)) of
(EqPred eq_rel1 ty1 _, EqPred eq_rel2 ty2 _) ->
(eq_rel1 == eq_rel2) && (ty1 `eqType` ty2)
- _ -> pprPanic "mkSkolReporter" (ppr ct1 $$ ppr ct2)
+ _ -> pprPanic "mkSkolReporter" (ppr item1 $$ ppr item2)
-cmp_loc :: Ct -> Ct -> Ordering
-cmp_loc ct1 ct2 = get ct1 `compare` get ct2
+cmp_loc :: ErrorItem -> ErrorItem -> Ordering
+cmp_loc item1 item2 = get item1 `compare` get item2
where
- get ct = realSrcSpanStart (ctLocSpan (ctLoc ct))
+ get ei = realSrcSpanStart (ctLocSpan (errorItemCtLoc ei))
-- Reduce duplication by reporting only one error from each
-- /starting/ location even if the end location differs
-reportGroup :: (SolverReportErrCtxt -> [Ct] -> TcM SolverReport) -> 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_ (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 :: (SolverReportErrCtxt -> [Ct] -> TcM SolverReport) -> Reporter
-suppressGroup mk_err ctxt cts
- = do { err <- mk_err ctxt cts
- ; traceTc "Suppressing errors for" (ppr cts)
- ; mapM_ (addDeferredBinding ctxt err) cts }
+reportGroup :: (SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport) -> Reporter
+reportGroup mk_err ctxt items
+ = do { err <- mk_err ctxt items
+ ; traceTc "About to maybeReportErr" $
+ vcat [ text "Constraint:" <+> ppr items
+ , text "cec_suppress =" <+> ppr (cec_suppress ctxt)
+ , text "cec_defer_type_errors =" <+> ppr (cec_defer_type_errors ctxt) ]
+ ; maybeReportError ctxt items err
+ -- But see Note [Always warn with -fdefer-type-errors]
+ ; traceTc "reportGroup" (ppr items)
+ ; mapM_ (addDeferredBinding ctxt err) items }
+ -- 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)
-- See Note [No deferring for multiplicity errors]
nonDeferrableOrigin :: CtOrigin -> Bool
@@ -868,23 +1007,33 @@ nonDeferrableOrigin (UsageEnvironmentOf {}) = True
nonDeferrableOrigin (FixedRuntimeRepOrigin {}) = True
nonDeferrableOrigin _ = False
-maybeReportError :: SolverReportErrCtxt -> Ct -> SolverReport -> TcM ()
-maybeReportError ctxt ct (SolverReport { sr_important_msgs = important, sr_supplementary = supp, sr_hints = hints })
- = unless (cec_suppress ctxt) $ -- Some worse error has occurred, so suppress this diagnostic
- do let reason | nonDeferrableOrigin (ctOrigin ct) = ErrorWithoutFlag
- | otherwise = cec_defer_type_errors ctxt
+maybeReportError :: SolverReportErrCtxt
+ -> [ErrorItem] -- items covered by the Report
+ -> SolverReport -> TcM ()
+maybeReportError ctxt items@(item1:_) (SolverReport { sr_important_msgs = 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 hints
- msg <- mkErrorReport (ctLocEnv (ctLoc ct)) diag (Just ctxt) supp
+ msg <- mkErrorReport (ctLocEnv (errorItemCtLoc item1)) diag (Just ctxt) supp
reportDiagnostic msg
+maybeReportError _ _ _ = panic "maybeReportError"
-addDeferredBinding :: SolverReportErrCtxt -> SolverReport -> Ct -> TcM ()
+addDeferredBinding :: SolverReportErrCtxt -> SolverReport -> ErrorItem -> TcM ()
-- See Note [Deferring coercion errors to runtime]
-addDeferredBinding ctxt err ct
+addDeferredBinding ctxt err (EI { ei_evdest = Just dest, ei_pred = item_ty
+ , ei_loc = loc })
+ -- if evdest is Just, then the constraint was from a wanted
| deferringAnyBindings ctxt
- , CtWanted { ctev_pred = pred, ctev_dest = dest } <- ctEvidence ct
- -- Only add deferred bindings for Wanted constraints
- = do { err_tm <- mkErrorTerm ctxt (ctLoc ct) pred err
+ = do { err_tm <- mkErrorTerm ctxt loc item_ty err
; let ev_binds_var = cec_binds ctxt
; case dest of
@@ -895,9 +1044,7 @@ addDeferredBinding ctxt err ct
let co_var = coHoleCoVar hole
; addTcEvBind ev_binds_var $ mkWantedEvBind co_var err_tm
; fillCoercionHole hole (mkTcCoVarCo co_var) }}
-
- | otherwise -- Do not set any evidence for Given/Derived
- = return ()
+addDeferredBinding _ _ _ = return () -- Do not set any evidence for Given
mkErrorTerm :: SolverReportErrCtxt -> CtLoc -> Type -- of the error term
-> SolverReport -> TcM EvTerm
@@ -913,42 +1060,44 @@ mkErrorTerm ctxt ct_loc ty (SolverReport { sr_important_msgs = important, sr_sup
; return $ evDelayedError ty err_str }
-tryReporters :: SolverReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (SolverReportErrCtxt, [Ct])
+tryReporters :: SolverReportErrCtxt -> [ReporterSpec] -> [ErrorItem] -> TcM (SolverReportErrCtxt, [ErrorItem])
-- Use the first reporter in the list whose predicate says True
-tryReporters ctxt reporters cts
- = do { let (vis_cts, invis_cts) = partition (isVisibleOrigin . ctOrigin) cts
- ; traceTc "tryReporters {" (ppr vis_cts $$ ppr invis_cts)
- ; (ctxt', cts') <- go ctxt reporters vis_cts invis_cts
- ; traceTc "tryReporters }" (ppr cts')
- ; return (ctxt', cts') }
+tryReporters ctxt reporters items
+ = do { let (vis_items, invis_items)
+ = partition (isVisibleOrigin . errorItemOrigin) items
+ ; traceTc "tryReporters {" (ppr vis_items $$ ppr invis_items)
+ ; (ctxt', items') <- go ctxt reporters vis_items invis_items
+ ; traceTc "tryReporters }" (ppr items')
+ ; return (ctxt', items') }
where
- go ctxt [] vis_cts invis_cts
- = return (ctxt, vis_cts ++ invis_cts)
+ go ctxt [] vis_items invis_items
+ = return (ctxt, vis_items ++ invis_items)
- go ctxt (r : rs) vis_cts invis_cts
+ go ctxt (r : rs) vis_items invis_items
-- always look at *visible* Origins before invisible ones
-- this is the whole point of isVisibleOrigin
- = do { (ctxt', vis_cts') <- tryReporter ctxt r vis_cts
- ; (ctxt'', invis_cts') <- tryReporter ctxt' r invis_cts
- ; go ctxt'' rs vis_cts' invis_cts' }
+ = do { (ctxt', vis_items') <- tryReporter ctxt r vis_items
+ ; (ctxt'', invis_items') <- tryReporter ctxt' r invis_items
+ ; go ctxt'' rs vis_items' invis_items' }
-- Carry on with the rest, because we must make
-- deferred bindings for them if we have -fdefer-type-errors
-- But suppress their error messages
-tryReporter :: SolverReportErrCtxt -> ReporterSpec -> [Ct] -> TcM (SolverReportErrCtxt, [Ct])
-tryReporter ctxt (str, keep_me, suppress_after, reporter) cts
+tryReporter :: SolverReportErrCtxt -> ReporterSpec -> [ErrorItem] -> TcM (SolverReportErrCtxt, [ErrorItem])
+tryReporter ctxt (str, keep_me, suppress_after, reporter) items
| null yeses
- = return (ctxt, cts)
+ = return (ctxt, items)
| otherwise
= do { traceTc "tryReporter{ " (text str <+> ppr yeses)
; (_, no_errs) <- askNoErrs (reporter ctxt yeses)
- ; let suppress_now = not no_errs && suppress_after
+ ; let suppress_now = not no_errs && suppress_after
-- See Note [Suppressing error messages]
ctxt' = ctxt { cec_suppress = suppress_now || cec_suppress ctxt }
; traceTc "tryReporter end }" (text str <+> ppr (cec_suppress ctxt) <+> ppr suppress_after)
; return (ctxt', nos) }
where
- (yeses, nos) = partition (\ct -> keep_me ct (classifyPredType (ctPred ct))) cts
+ (yeses, nos) = partition keep items
+ keep item = keep_me item (classifyPredType (errorItemPred item))
-- | Wrap an input 'TcRnMessage' with additional contextual information,
-- such as relevant bindings or valid hole fits.
@@ -1069,56 +1218,6 @@ from that EvVar, filling the hole with that coercion. Because coercions'
types are unlifted, the error is guaranteed to be hit before we get to the
coercion.
-Note [Do not report derived but soluble errors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The wc_simples include Derived constraints that have not been solved,
-but are not insoluble (in that case they'd be reported by 'report1').
-We do not want to report these as errors:
-
-* Superclass constraints. If we have an unsolved [W] Ord a, we'll also have
- an unsolved [D] Eq a, and we do not want to report that; it's just noise.
-
-* Functional dependencies. For givens, consider
- class C a b | a -> b
- data T a where
- MkT :: C a d => [d] -> T a
- f :: C a b => T a -> F Int
- f (MkT xs) = length xs
- Then we get a [D] b~d. But there *is* a legitimate call to
- f, namely f (MkT [True]) :: T Bool, in which b=d. So we should
- not reject the program.
-
- For wanteds, something similar
- data T a where
- MkT :: C Int b => a -> b -> T a
- g :: C Int c => c -> ()
- f :: T a -> ()
- f (MkT x y) = g x
- Here we get [G] C Int b, [W] C Int a, hence [D] a~b.
- But again f (MkT True True) is a legitimate call.
-
-(We leave the Deriveds in wc_simple until reportErrors, so that we don't lose
-derived superclasses between iterations of the solver.)
-
-For functional dependencies, here is a real example,
-stripped off from libraries/utf8-string/Codec/Binary/UTF8/Generic.hs
-
- class C a b | a -> b
- g :: C a b => a -> b -> ()
- f :: C a b => a -> b -> ()
- f xa xb =
- let loop = g xa
- in loop xb
-
-We will first try to infer a type for loop, and we will succeed:
- C a b' => b' -> ()
-Subsequently, we will type check (loop xb) and all is good. But,
-recall that we have to solve a final implication constraint:
- C a b => (C a b' => .... cts from body of loop .... ))
-And now we have a problem as we will generate an equality b ~ b' and fail to
-solve it.
-
-
************************************************************************
* *
Irreducible predicate errors
@@ -1126,14 +1225,23 @@ solve it.
************************************************************************
-}
-mkIrredErr :: SolverReportErrCtxt -> [Ct] -> TcM SolverReport
-mkIrredErr ctxt cts
- = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1
+mkIrredErr :: SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport
+mkIrredErr ctxt items
+ = do { (ctxt, binds_msg, item1) <- relevantBindings True ctxt item1
; let msg = important ctxt $
- CouldNotDeduce (getUserGivens ctxt) (ct1 :| others) Nothing
+ CouldNotDeduce (getUserGivens ctxt) (item1 :| others) Nothing
; return $ msg `mappend` mk_relevant_bindings binds_msg }
where
- ct1:others = cts
+ (item1:others) = final_items
+
+ filtered_items = filter (not . ei_suppress) items
+ final_items | null filtered_items = items
+ -- they're all suppressed; must report *something*
+ -- NB: even though reportWanteds asserts that not
+ -- all items are suppressed, it's possible all the
+ -- irreducibles are suppressed, and so this function
+ -- might get all suppressed items
+ | otherwise = filtered_items
{- Note [Constructing Hole Errors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1171,7 +1279,7 @@ See also 'reportUnsolved'.
----------------
-- | Constructs a new hole error, unless this is deferred. See Note [Constructing Hole Errors].
-mkHoleError :: NameEnv Type -> [Ct] -> SolverReportErrCtxt -> Hole -> TcM (MsgEnvelope TcRnMessage)
+mkHoleError :: NameEnv Type -> [ErrorItem] -> SolverReportErrCtxt -> Hole -> TcM (MsgEnvelope TcRnMessage)
mkHoleError _ _tidy_simples ctxt hole@(Hole { hole_occ = occ, hole_loc = ct_loc })
| isOutOfScopeHole hole
= do { dflags <- getDynFlags
@@ -1277,19 +1385,27 @@ maybeAddDeferredBindings ctxt hole report = do
-- We unwrap the SolverReportErrCtxt here, to avoid introducing a loop in module
-- imports
-validHoleFits :: SolverReportErrCtxt -- ^ The context we're in, i.e. the
- -- implications and the tidy environment
- -> [Ct] -- ^ Unsolved simple constraints
- -> Hole -- ^ The hole
- -> TcM (SolverReportErrCtxt, ValidHoleFits)
- -- ^ We return the new context
- -- with a possibly updated
- -- tidy environment, and
- -- the valid hole fits.
-validHoleFits ctxt@(CEC {cec_encl = implics
- , cec_tidy = lcl_env}) simps hole
- = do { (tidy_env, fits) <- findValidHoleFits lcl_env implics simps hole
+validHoleFits :: SolverReportErrCtxt -- ^ The context we're in, i.e. the
+ -- implications and the tidy environment
+ -> [ErrorItem] -- ^ Unsolved simple constraints
+ -> Hole -- ^ The hole
+ -> TcM (SolverReportErrCtxt, ValidHoleFits)
+ -- ^ We return the new context
+ -- with a possibly updated
+ -- tidy environment, and
+ -- the valid hole fits.
+validHoleFits ctxt@(CEC { cec_encl = implics
+ , cec_tidy = lcl_env}) simps hole
+ = do { (tidy_env, fits) <- findValidHoleFits lcl_env implics (map mk_wanted simps) hole
; return (ctxt {cec_tidy = tidy_env}, fits) }
+ where
+ mk_wanted :: ErrorItem -> CtEvidence
+ mk_wanted (EI { ei_pred = pred, ei_evdest = Just dest, ei_loc = loc })
+ = CtWanted { ctev_pred = pred
+ , ctev_dest = dest
+ , ctev_loc = loc
+ , ctev_rewriters = emptyRewriterSet }
+ mk_wanted item = pprPanic "validHoleFits no evdest" (ppr item)
-- See Note [Constraints include ...]
givenConstraints :: SolverReportErrCtxt -> [(Type, RealSrcSpan)]
@@ -1300,13 +1416,16 @@ givenConstraints ctxt
----------------
-mkIPErr :: SolverReportErrCtxt -> [Ct] -> TcM SolverReport
-mkIPErr ctxt cts
- = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1
- ; let msg = important ctxt $ UnboundImplicitParams (ct1 :| others)
+mkIPErr :: SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport
+-- What would happen if an item is suppressed because of
+-- Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint? Very unclear
+-- what's best. Let's not worry about this.
+mkIPErr ctxt items
+ = do { (ctxt, binds_msg, item1) <- relevantBindings True ctxt item1
+ ; let msg = important ctxt $ UnboundImplicitParams (item1 :| others)
; return $ msg `mappend` mk_relevant_bindings binds_msg }
where
- ct1:others = cts
+ item1:others = items
----------------
@@ -1314,15 +1433,15 @@ mkIPErr ctxt cts
-- Wanted constraints arising from representation-polymorphism checks.
--
-- See Note [Reporting representation-polymorphism errors] in GHC.Tc.Types.Origin.
-mkFRRErr :: SolverReportErrCtxt -> [Ct] -> TcM SolverReport
-mkFRRErr ctxt cts
+mkFRRErr :: SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport
+mkFRRErr ctxt items
= do { -- Zonking/tidying.
; origs <-
-- Zonk/tidy the 'CtOrigin's.
- zonkTidyOrigins (cec_tidy ctxt) (map ctOrigin cts)
+ zonkTidyOrigins (cec_tidy ctxt) (map errorItemOrigin items)
<&>
-- Then remove duplicates: only retain one 'CtOrigin' per representation-polymorphic type.
- (nubOrdBy (nonDetCmpType `on` (snd . frr_orig_and_type)) . snd)
+ (nubOrdBy (nonDetCmpType `on` (snd . frr_orig_and_type)) . snd)
-- Obtain all the errors we want to report (constraints with FixedRuntimeRep origin),
-- with the corresponding types:
-- ty1 :: TYPE rep1, ty2 :: TYPE rep2, ...
@@ -1396,21 +1515,29 @@ 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 :: SolverReportErrCtxt -> [Ct] -> TcM SolverReport
-mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct
-mkEqErr _ [] = panic "mkEqErr"
-
-mkEqErr1 :: SolverReportErrCtxt -> Ct -> TcM SolverReport
-mkEqErr1 ctxt ct -- Wanted or derived;
- -- givens handled in mkGivenErrorReporter
- = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
+mkEqErr :: SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport
+mkEqErr ctxt items
+ | item:_ <- filter (not . ei_suppress) items
+ = mkEqErr1 ctxt item
+
+ | item:_ <- items -- they're all suppressed. still need an error message
+ -- for -fdefer-type-errors though
+ = mkEqErr1 ctxt item
+
+ | otherwise
+ = panic "mkEqErr" -- guaranteed to have at least one item
+
+mkEqErr1 :: SolverReportErrCtxt -> ErrorItem -> TcM SolverReport
+mkEqErr1 ctxt item -- Wanted only
+ -- givens handled in mkGivenErrorReporter
+ = do { (ctxt, binds_msg, item) <- relevantBindings True ctxt item
; rdr_env <- getGlobalRdrEnv
; fam_envs <- tcGetFamInstEnvs
- ; let mb_coercible_msg = case ctEqRel ct of
+ ; let mb_coercible_msg = case errorItemEqRel item of
NomEq -> Nothing
ReprEq -> ReportCoercibleMsg <$> mkCoercibleExplanation rdr_env fam_envs ty1 ty2
- ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctOrigin ct))
- ; (last_msg :| prev_msgs, hints) <- mkEqErr_help ctxt ct ty1 ty2
+ ; traceTc "mkEqErr1" (ppr item $$ pprCtOrigin (errorItemOrigin item))
+ ; (last_msg :| prev_msgs, hints) <- mkEqErr_help ctxt item ty1 ty2
; let
report = foldMap (important ctxt) (reverse prev_msgs)
`mappend` (important ctxt $ mkTcReportWithInfo last_msg $ maybeToList mb_coercible_msg)
@@ -1418,7 +1545,7 @@ mkEqErr1 ctxt ct -- Wanted or derived;
`mappend` (mk_report_hints hints)
; return report }
where
- (ty1, ty2) = getEqPredTys (ctPred ct)
+ (ty1, ty2) = getEqPredTys (errorItemPred item)
-- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint
-- is left over.
@@ -1465,41 +1592,40 @@ mkCoercibleExplanation rdr_env fam_envs ty1 ty2
type AccReportMsgs = NonEmpty TcSolverReportMsg
mkEqErr_help :: SolverReportErrCtxt
- -> Ct
+ -> ErrorItem
-> TcType -> TcType -> TcM (AccReportMsgs, [GhcHint])
-mkEqErr_help ctxt ct ty1 ty2
+mkEqErr_help ctxt item ty1 ty2
| Just (tv1, _) <- tcGetCastedTyVar_maybe ty1
- = mkTyVarEqErr ctxt ct tv1 ty2
+ = mkTyVarEqErr ctxt item tv1 ty2
| Just (tv2, _) <- tcGetCastedTyVar_maybe ty2
- = mkTyVarEqErr ctxt ct tv2 ty1
+ = mkTyVarEqErr ctxt item tv2 ty1
| otherwise
- = return (reportEqErr ctxt ct ty1 ty2 :| [], [])
+ = return (reportEqErr ctxt item ty1 ty2 :| [], [])
reportEqErr :: SolverReportErrCtxt
- -> Ct
+ -> ErrorItem
-> TcType -> TcType -> TcSolverReportMsg
-reportEqErr ctxt ct ty1 ty2
+reportEqErr ctxt item ty1 ty2
= mkTcReportWithInfo mismatch eqInfos
where
- mismatch = misMatchOrCND False ctxt ct ty1 ty2
- eqInfos = eqInfoMsgs ct ty1 ty2
+ mismatch = misMatchOrCND False ctxt item ty1 ty2
+ eqInfos = eqInfoMsgs ty1 ty2
-mkTyVarEqErr :: SolverReportErrCtxt -> Ct
+mkTyVarEqErr :: SolverReportErrCtxt -> ErrorItem
-> TcTyVar -> TcType -> TcM (AccReportMsgs, [GhcHint])
-- tv1 and ty2 are already tidied
-mkTyVarEqErr ctxt ct tv1 ty2
- = do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr ty2)
- ; dflags <- getDynFlags
- ; mkTyVarEqErr' dflags ctxt ct tv1 ty2 }
+mkTyVarEqErr ctxt item tv1 ty2
+ = do { traceTc "mkTyVarEqErr" (ppr item $$ ppr tv1 $$ ppr ty2)
+ ; mkTyVarEqErr' ctxt item tv1 ty2 }
-mkTyVarEqErr' :: DynFlags -> SolverReportErrCtxt -> Ct
+mkTyVarEqErr' :: SolverReportErrCtxt -> ErrorItem
-> TcTyVar -> TcType -> TcM (AccReportMsgs, [GhcHint])
-mkTyVarEqErr' dflags ctxt ct tv1 ty2
+mkTyVarEqErr' ctxt item tv1 ty2
-- impredicativity is a simple error to understand; try it first
| check_eq_result `cterHasProblem` cteImpredicative = do
tyvar_eq_info <- extraTyVarEqInfo tv1 ty2
let
- poly_msg = CannotUnifyWithPolytype ct tv1 ty2
+ poly_msg = CannotUnifyWithPolytype item tv1 ty2
poly_msg_with_info
| isSkolemTyVar tv1
= mkTcReportWithInfo poly_msg tyvar_eq_info
@@ -1513,7 +1639,7 @@ mkTyVarEqErr' dflags ctxt 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
+ || errorItemEqRel item == ReprEq
-- The cases below don't really apply to ReprEq (except occurs check)
= do
tv_extra <- extraTyVarEqInfo tv1 ty2
@@ -1523,7 +1649,7 @@ mkTyVarEqErr' dflags ctxt ct tv1 ty2
-- 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
- = let extras2 = eqInfoMsgs ct ty1 ty2
+ = let extras2 = eqInfoMsgs ty1 ty2
interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $
filter isTyVar $
@@ -1536,6 +1662,11 @@ mkTyVarEqErr' dflags ctxt ct tv1 ty2
in return (mkTcReportWithInfo headline_msg (extras2 ++ extras3) :| [], [])
+ -- This is wrinkle (4) in Note [Equalities with incompatible kinds] in
+ -- GHC.Tc.Solver.Canonical
+ | hasCoercionHoleTy ty2
+ = return (mkBlockedEqErr item :| [], [])
+
-- If the immediately-enclosing implication has 'tv' a skolem, and
-- we know by now its an InferSkol kind of skolem, then presumably
-- it started life as a TyVarTv, else it'd have been unified, given
@@ -1552,7 +1683,7 @@ mkTyVarEqErr' dflags ctxt ct tv1 ty2
, Implic { ic_skols = skols } <- implic
, let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols
, not (null esc_skols)
- = return (SkolemEscape ct implic esc_skols :| [mismatch_msg], [])
+ = return (SkolemEscape item implic esc_skols :| [mismatch_msg], [])
-- Nastiest case: attempt to unify an untouchable variable
-- So tv is a meta tyvar (or started that way before we
@@ -1568,43 +1699,48 @@ mkTyVarEqErr' dflags ctxt ct tv1 ty2
return (mkTcReportWithInfo tclvl_extra tv_extra :| [mismatch_msg], add_sig)
| otherwise
- = return (reportEqErr ctxt ct (mkTyVarTy tv1) ty2 :| [], [])
+ = return (reportEqErr ctxt item (mkTyVarTy tv1) ty2 :| [], [])
-- This *can* happen (#6123)
-- Consider an ambiguous top-level constraint (a ~ F a)
-- Not an occurs check, because F is a type function.
where
- headline_msg = misMatchOrCND insoluble_occurs_check ctxt ct ty1 ty2
- mismatch_msg = mkMismatchMsg ct ty1 ty2
+ headline_msg = misMatchOrCND insoluble_occurs_check ctxt item ty1 ty2
+ mismatch_msg = mkMismatchMsg item ty1 ty2
add_sig = maybeToList $ suggestAddSig ctxt ty1 ty2
ty1 = mkTyVarTy tv1
- check_eq_result = case ct of
- CIrredCan { cc_reason = NonCanonicalReason result } -> result
- CIrredCan { cc_reason = HoleBlockerReason {} } -> cteProblem cteHoleBlocker
- _ -> checkTyVarEq dflags tv1 ty2
+ check_eq_result = case ei_m_reason item of
+ Just (NonCanonicalReason result) -> result
+ _ -> checkTyVarEq tv1 ty2
-- in T2627b, we report an error for F (F a0) ~ a0. Note that the type
-- variable is on the right, so we don't get useful info for the CIrredCan,
-- and have to compute the result of checkTyVarEq here.
insoluble_occurs_check = check_eq_result `cterHasProblem` cteInsolubleOccurs
-eqInfoMsgs :: Ct -> TcType -> TcType -> [TcSolverReportInfo]
+eqInfoMsgs :: TcType -> TcType -> [TcSolverReportInfo]
-- Report (a) ambiguity if either side is a type function application
-- e.g. F a0 ~ Int
-- (b) warning about injectivity if both sides are the same
-- type function application F a ~ F b
-- See Note [Non-injective type functions]
-eqInfoMsgs ct ty1 ty2
+eqInfoMsgs ty1 ty2
= catMaybes [tyfun_msg, ambig_msg]
where
mb_fun1 = isTyFun_maybe ty1
mb_fun2 = isTyFun_maybe ty2
- (ambig_kvs, ambig_tvs) = getAmbigTkvs ct
+
+ -- if a type isn't headed by a type function, then any ambiguous
+ -- variables need not be reported as such. e.g.: F a ~ t0 -> t0, where a is a skolem
+ ambig_tkvs1 = maybe mempty (\_ -> ambigTkvsOfTy ty1) mb_fun1
+ ambig_tkvs2 = maybe mempty (\_ -> ambigTkvsOfTy ty2) mb_fun2
+
+ ambig_tkvs@(ambig_kvs, ambig_tvs) = ambig_tkvs1 S.<> ambig_tkvs2
ambig_msg | isJust mb_fun1 || isJust mb_fun2
, not (null ambig_kvs && null ambig_tvs)
- = Just $ Ambiguity False (ambig_kvs, ambig_tvs)
+ = Just $ Ambiguity False ambig_tkvs
| otherwise
= Nothing
@@ -1616,24 +1752,23 @@ eqInfoMsgs ct ty1 ty2
| otherwise
= Nothing
-misMatchOrCND :: Bool -> SolverReportErrCtxt -> Ct
+misMatchOrCND :: Bool -> SolverReportErrCtxt -> ErrorItem
-> TcType -> TcType -> TcSolverReportMsg
-- If oriented then ty1 is actual, ty2 is expected
-misMatchOrCND insoluble_occurs_check ctxt ct ty1 ty2
+misMatchOrCND insoluble_occurs_check ctxt item ty1 ty2
| insoluble_occurs_check -- See Note [Insoluble occurs check]
|| (isRigidTy ty1 && isRigidTy ty2)
- || isGivenCt ct
+ || (ei_flavour item == Given)
|| null givens
= -- If the equality is unconditionally insoluble
-- or there is no context, don't report the context
- mkMismatchMsg ct ty1 ty2
+ mkMismatchMsg item ty1 ty2
| otherwise
- = CouldNotDeduce givens (ct :| []) (Just $ CND_Extra level ty1 ty2)
+ = CouldNotDeduce givens (item :| []) (Just $ CND_Extra level ty1 ty2)
where
- ev = ctEvidence ct
- level = ctLocTypeOrKind_maybe (ctEvLoc ev) `orElse` TypeLevel
+ level = ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel
givens = [ given | given <- getUserGivens ctxt, ic_given_eqs given /= NoGivenEqs ]
-- Keep only UserGivens that have some equalities.
-- See Note [Suppress redundant givens during error reporting]
@@ -1643,9 +1778,8 @@ misMatchOrCND insoluble_occurs_check ctxt ct ty1 ty2
-- 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 :: SolverReportErrCtxt -> [Ct] -> TcM SolverReport
-mkBlockedEqErr ctxt (ct:_) = return $ important ctxt (BlockedEquality ct)
-mkBlockedEqErr _ [] = panic "mkBlockedEqErr no constraints"
+mkBlockedEqErr :: ErrorItem -> TcSolverReportMsg
+mkBlockedEqErr item = BlockedEquality item
{-
Note [Suppress redundant givens during error reporting]
@@ -1732,53 +1866,49 @@ suggestAddSig ctxt ty1 _ty2
= find implics (seen_eqs || ic_given_eqs implic /= NoGivenEqs) tv
--------------------
-
-mkMismatchMsg :: Ct -> Type -> Type -> TcSolverReportMsg
-mkMismatchMsg ct ty1 ty2 =
- case ctOrigin ct of
+mkMismatchMsg :: ErrorItem -> Type -> Type -> TcSolverReportMsg
+mkMismatchMsg item ty1 ty2 =
+ case orig of
TypeEqOrigin { uo_actual, uo_expected, uo_thing = mb_thing } ->
mkTcReportWithInfo
(TypeEqMismatch
{ teq_mismatch_ppr_explicit_kinds = ppr_explicit_kinds
- , teq_mismatch_ct = ct
- , teq_mismatch_ty1 = ty1
- , teq_mismatch_ty2 = ty2
+ , teq_mismatch_item = item
+ , teq_mismatch_ty1 = ty1
+ , teq_mismatch_ty2 = ty2
, teq_mismatch_actual = uo_actual
, teq_mismatch_expected = uo_expected
, teq_mismatch_what = mb_thing})
extras
KindEqOrigin cty1 cty2 sub_o mb_sub_t_or_k ->
- mkTcReportWithInfo (Mismatch False ct ty1 ty2)
+ mkTcReportWithInfo (Mismatch False item ty1 ty2)
(WhenMatching cty1 cty2 sub_o mb_sub_t_or_k : extras)
_ ->
mkTcReportWithInfo
- (Mismatch False ct ty1 ty2)
+ (Mismatch False item ty1 ty2)
extras
where
- orig = ctOrigin ct
+ orig = errorItemOrigin item
extras = sameOccExtras ty2 ty1
ppr_explicit_kinds = shouldPprWithExplicitKinds ty1 ty2 orig
--- | Whether to prints explicit kinds (with @-fprint-explicit-kinds@)
+-- | Whether to print explicit kinds (with @-fprint-explicit-kinds@)
-- in an 'SDoc' when a type mismatch occurs to due invisible kind arguments.
--
-- This function first checks to see if the 'CtOrigin' argument is a
--- 'TypeEqOrigin', and if so, uses the expected/actual types from that to
--- check for a kind mismatch (as these types typically have more surrounding
--- types and are likelier to be able to glean information about whether a
--- mismatch occurred in an invisible argument position or not). If the
--- 'CtOrigin' is not a 'TypeEqOrigin', fall back on the actual mismatched types
--- themselves.
+-- 'TypeEqOrigin'. If so, it first checks whether the equality is a visible
+-- equality; if it's not, definitely print the kinds. Even if the equality is
+-- a visible equality, check the expected/actual types to see if the types
+-- have equal visible components. If the 'CtOrigin' is
+-- not a 'TypeEqOrigin', fall back on the actual mismatched types themselves.
shouldPprWithExplicitKinds :: Type -> Type -> CtOrigin -> Bool
-shouldPprWithExplicitKinds ty1 ty2 ct
- = tcEqTypeVis act_ty exp_ty
- -- True when the visible bit of the types look the same,
- -- so we want to show the kinds in the displayed type.
- where
- (act_ty, exp_ty) = case ct of
- TypeEqOrigin { uo_actual = act
- , uo_expected = exp } -> (act, exp)
- _ -> (ty1, ty2)
+shouldPprWithExplicitKinds _ty1 _ty2 (TypeEqOrigin { uo_actual = act
+ , uo_expected = exp
+ , uo_visible = vis })
+ | not vis = True -- See tests T15870, T16204c
+ | otherwise = tcEqTypeVis act exp -- See tests T9171, T9144.
+shouldPprWithExplicitKinds ty1 ty2 _ct
+ = tcEqTypeVis ty1 ty2
{- Note [Insoluble occurs check]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1880,39 +2010,44 @@ Warn of loopy local equalities that were dropped.
************************************************************************
-}
-mkDictErr :: HasDebugCallStack => SolverReportErrCtxt -> [Ct] -> TcM SolverReport
-mkDictErr ctxt cts
- = assert (not (null cts)) $
+mkDictErr :: HasDebugCallStack => SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport
+mkDictErr ctxt orig_items
+ = assert (not (null items)) $
do { inst_envs <- tcGetInstEnvs
- ; 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
+ ; let min_items = elim_superclasses items
+ lookups = map (lookup_cls_inst inst_envs) min_items
+ (no_inst_items, overlap_items) = partition is_no_inst lookups
-- Report definite no-instance errors,
-- or (iff there are none) overlap errors
-- 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
- ; err <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts))
+ ; err <- mk_dict_err ctxt (head (no_inst_items ++ overlap_items))
; return $ important ctxt err }
where
+ filtered_items = filter (not . ei_suppress) orig_items
+ items | null filtered_items = orig_items -- all suppressed, but must report
+ -- something for -fdefer-type-errors
+ | otherwise = filtered_items -- common case
+
no_givens = null (getUserGivens ctxt)
- is_no_inst (ct, (matches, unifiers, _))
+ is_no_inst (item, (matches, unifiers, _))
= no_givens
&& null matches
- && (nullUnifiers unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfCtList ct))
+ && (nullUnifiers unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfTypeList (errorItemPred item)))
- lookup_cls_inst inst_envs ct
- = (ct, lookupInstEnv True inst_envs clas tys)
+ lookup_cls_inst inst_envs item
+ = (item, lookupInstEnv True inst_envs clas tys)
where
- (clas, tys) = getClassPredTys (ctPred ct)
+ (clas, tys) = getClassPredTys (errorItemPred item)
-- When simplifying [W] Ord (Set a), we need
-- [W] Eq a, [W] Ord a
-- but we really only want to report the latter
- elim_superclasses cts = mkMinimalBySCs ctPred cts
+ elim_superclasses items = mkMinimalBySCs errorItemPred items
-- Note [mk_dict_err]
-- ~~~~~~~~~~~~~~~~~~~
@@ -1925,16 +2060,16 @@ mkDictErr ctxt cts
-- - One match, one or more unifiers: report "Overlapping instances for", show the
-- matching and unifying instances, and say "The choice depends on the instantion of ...,
-- and the result of evaluating ...".
-mk_dict_err :: HasCallStack => SolverReportErrCtxt -> (Ct, ClsInstLookupResult)
+mk_dict_err :: HasCallStack => SolverReportErrCtxt -> (ErrorItem, ClsInstLookupResult)
-> TcM TcSolverReportMsg
-- Report an overlap error if this class constraint results
-- from an overlap (returning Left clas), otherwise return (Right pred)
-mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped))
+mk_dict_err ctxt (item, (matches, unifiers, unsafe_overlapped))
| null matches -- No matches but perhaps several unifiers
- = do { (_, rel_binds, ct) <- relevantBindings True ctxt ct
+ = do { (_, rel_binds, item) <- relevantBindings True ctxt item
; candidate_insts <- get_candidate_instances
; (imp_errs, field_suggestions) <- record_field_suggestions
- ; return (cannot_resolve_msg ct candidate_insts rel_binds imp_errs field_suggestions) }
+ ; return (cannot_resolve_msg item candidate_insts rel_binds imp_errs field_suggestions) }
| null unsafe_overlapped -- Some matches => overlap errors
= return $ overlap_msg
@@ -1942,8 +2077,8 @@ mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped))
| otherwise
= return $ safe_haskell_msg
where
- orig = ctOrigin ct
- pred = ctPred ct
+ orig = errorItemOrigin item
+ pred = errorItemPred item
(clas, tys) = getClassPredTys pred
ispecs = [ispec | (ispec, _) <- matches]
unsafe_ispecs = [ispec | (ispec, _) <- unsafe_overlapped]
@@ -1990,21 +2125,22 @@ mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped))
HasFieldOrigin name -> Just (mkVarOccFS name)
_ -> Nothing
- cannot_resolve_msg :: Ct -> [ClsInst] -> RelevantBindings -> [ImportError] -> [GhcHint] -> TcSolverReportMsg
- cannot_resolve_msg ct candidate_insts binds imp_errs field_suggestions
- = CannotResolveInstance ct (getPotentialUnifiers unifiers) candidate_insts imp_errs field_suggestions binds
+ cannot_resolve_msg :: ErrorItem -> [ClsInst] -> RelevantBindings
+ -> [ImportError] -> [GhcHint] -> TcSolverReportMsg
+ cannot_resolve_msg item candidate_insts binds imp_errs field_suggestions
+ = CannotResolveInstance item (getPotentialUnifiers unifiers) candidate_insts imp_errs field_suggestions binds
-- Overlap errors.
overlap_msg, safe_haskell_msg :: TcSolverReportMsg
-- Normal overlap error
overlap_msg
- = assert (not (null matches)) $ OverlappingInstances ct ispecs (getPotentialUnifiers unifiers)
+ = assert (not (null matches)) $ OverlappingInstances item ispecs (getPotentialUnifiers unifiers)
-- Overlap error because of Safe Haskell (first
-- match should be the most specific match)
safe_haskell_msg
= assert (matches `lengthIs` 1 && not (null unsafe_ispecs)) $
- UnsafeOverlap ct ispecs unsafe_ispecs
+ UnsafeOverlap item ispecs unsafe_ispecs
{- Note [Report candidate instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2086,14 +2222,6 @@ the above error message would instead be displayed as:
Which makes it clearer that the culprit is the mismatch between `k2` and `k20`.
-}
-getAmbigTkvs :: Ct -> ([Var],[Var])
-getAmbigTkvs ct
- = partition (`elemVarSet` dep_tkv_set) ambig_tkvs
- where
- tkvs = tyCoVarsOfCtList ct
- ambig_tkvs = filter isAmbiguousTyVar tkvs
- dep_tkv_set = tyCoVarsOfTypes (map tyVarKind tkvs)
-
-----------------------
-- relevantBindings looks at the value environment and finds values whose
-- types mention any of the offending type variables. It has to be
@@ -2105,11 +2233,11 @@ getAmbigTkvs ct
relevantBindings :: Bool -- True <=> filter by tyvar; False <=> no filtering
-- See #8191
- -> SolverReportErrCtxt -> Ct
- -> TcM (SolverReportErrCtxt, RelevantBindings, Ct)
+ -> SolverReportErrCtxt -> ErrorItem
+ -> TcM (SolverReportErrCtxt, RelevantBindings, ErrorItem)
-- Also returns the zonked and tidied CtOrigin of the constraint
-relevantBindings want_filtering ctxt ct
- = do { traceTc "relevantBindings" (ppr ct)
+relevantBindings want_filtering ctxt item
+ = do { traceTc "relevantBindings" (ppr item)
; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc)
-- For *kind* errors, report the relevant bindings of the
@@ -2117,19 +2245,19 @@ relevantBindings want_filtering ctxt ct
; let extra_tvs = case tidy_orig of
KindEqOrigin t1 t2 _ _ -> tyCoVarsOfTypes [t1,t2]
_ -> emptyVarSet
- ct_fvs = tyCoVarsOfCt ct `unionVarSet` extra_tvs
+ ct_fvs = tyCoVarsOfType (errorItemPred item) `unionVarSet` extra_tvs
- -- Put a zonked, tidied CtOrigin into the Ct
+ -- Put a zonked, tidied CtOrigin into the ErrorItem
loc' = setCtLocOrigin loc tidy_orig
- ct' = setCtLoc ct loc'
+ item' = item { ei_loc = loc' }
; (env2, lcl_name_cache) <- zonkTidyTcLclEnvs env1 [lcl_env]
; relev_bds <- relevant_bindings want_filtering lcl_env lcl_name_cache ct_fvs
; let ctxt' = ctxt { cec_tidy = env2 }
- ; return (ctxt', relev_bds, ct') }
+ ; return (ctxt', relev_bds, item') }
where
- loc = ctLoc ct
+ loc = errorItemCtLoc item
lcl_env = ctLocEnv loc
-- slightly more general version, to work also with holes
@@ -2222,9 +2350,12 @@ warnDefaulting _ [] _
warnDefaulting the_tv wanteds@(ct:_) default_ty
= do { warn_default <- woptM Opt_WarnTypeDefaults
; env0 <- tcInitTidyEnv
- ; let tidy_env = tidyFreeTyCoVars env0 $
- tyCoVarsOfCtsList (listToBag wanteds)
- tidy_wanteds = map (tidyCt tidy_env) wanteds
+ -- don't want to report all the superclass constraints, which
+ -- add unhelpful clutter
+ ; let filtered = filter (not . isWantedSuperclassOrigin . ctOrigin) wanteds
+ tidy_env = tidyFreeTyCoVars env0 $
+ tyCoVarsOfCtsList (listToBag filtered)
+ tidy_wanteds = map (tidyCt tidy_env) filtered
tidy_tv = lookupVarEnv (snd tidy_env) the_tv
diag = TcRnWarnDefaulting tidy_wanteds tidy_tv default_ty
loc = ctLoc ct
@@ -2236,36 +2367,8 @@ Note [Runtime skolems]
We want to give a reasonably helpful error message for ambiguity
arising from *runtime* skolems in the debugger. These
are created by in GHC.Runtime.Heap.Inspect.zonkRTTIType.
-
-************************************************************************
-* *
- Error from the canonicaliser
- These ones are called *during* constraint simplification
-* *
-************************************************************************
-}
-solverDepthErrorTcS :: CtLoc -> TcType -> TcM a
-solverDepthErrorTcS loc ty
- = setCtLocM loc $
- do { ty <- zonkTcType ty
- ; env0 <- tcInitTidyEnv
- ; let tidy_env = tidyFreeTyCoVars env0 (tyCoVarsOfTypeList ty)
- tidy_ty = tidyType tidy_env ty
- msg = TcRnUnknownMessage $ mkPlainError noHints $
- vcat [ text "Reduction stack overflow; size =" <+> ppr depth
- , hang (text "When simplifying the following type:")
- 2 (ppr tidy_ty)
- , note ]
- ; failWithTcM (tidy_env, msg) }
- where
- depth = ctLocDepth loc
- note = vcat
- [ text "Use -freduction-depth=0 to disable this check"
- , text "(any upper bound you could choose might fail unpredictably with"
- , text " minor updates to GHC, so disabling the check is recommended if"
- , text " you're sure that type checking should terminate)" ]
-
{-**********************************************************************
* *
GHC API helper functions