MonadFail proposal, phase 1
[ghc.git] / compiler / typecheck / TcErrors.hs
1 {-# LANGUAGE CPP, ScopedTypeVariables #-}
2
3 module TcErrors(
4 reportUnsolved, reportAllUnsolved, warnAllUnsolved,
5 warnDefaulting,
6
7 solverDepthErrorTcS
8 ) where
9
10 #include "HsVersions.h"
11
12 import TcRnTypes
13 import TcRnMonad
14 import TcMType
15 import TcType
16 import RnEnv( unknownNameSuggestions )
17 import TypeRep
18 import Type
19 import Kind ( isKind )
20 import Unify ( tcMatchTys )
21 import Module
22 import FamInst
23 import Inst
24 import InstEnv
25 import TyCon
26 import DataCon
27 import TcEvidence
28 import Name
29 import RdrName ( lookupGRE_Name, GlobalRdrEnv, mkRdrUnqual )
30 import Class( className )
31 import PrelNames( typeableClassName )
32 import Id
33 import Var
34 import VarSet
35 import VarEnv
36 import NameSet
37 import Bag
38 import ErrUtils ( ErrMsg, pprLocErrMsg )
39 import BasicTypes
40 import Util
41 import FastString
42 import Outputable
43 import SrcLoc
44 import DynFlags
45 import StaticFlags ( opt_PprStyle_Debug )
46 import ListSetOps ( equivClasses )
47
48 import Control.Monad ( when )
49 import Data.Maybe
50 import Data.List ( partition, mapAccumL, nub, sortBy )
51
52 {-
53 ************************************************************************
54 * *
55 \section{Errors and contexts}
56 * *
57 ************************************************************************
58
59 ToDo: for these error messages, should we note the location as coming
60 from the insts, or just whatever seems to be around in the monad just
61 now?
62
63 Note [Deferring coercion errors to runtime]
64 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
65 While developing, sometimes it is desirable to allow compilation to succeed even
66 if there are type errors in the code. Consider the following case:
67
68 module Main where
69
70 a :: Int
71 a = 'a'
72
73 main = print "b"
74
75 Even though `a` is ill-typed, it is not used in the end, so if all that we're
76 interested in is `main` it is handy to be able to ignore the problems in `a`.
77
78 Since we treat type equalities as evidence, this is relatively simple. Whenever
79 we run into a type mismatch in TcUnify, we normally just emit an error. But it
80 is always safe to defer the mismatch to the main constraint solver. If we do
81 that, `a` will get transformed into
82
83 co :: Int ~ Char
84 co = ...
85
86 a :: Int
87 a = 'a' `cast` co
88
89 The constraint solver would realize that `co` is an insoluble constraint, and
90 emit an error with `reportUnsolved`. But we can also replace the right-hand side
91 of `co` with `error "Deferred type error: Int ~ Char"`. This allows the program
92 to compile, and it will run fine unless we evaluate `a`. This is what
93 `deferErrorsToRuntime` does.
94
95 It does this by keeping track of which errors correspond to which coercion
96 in TcErrors. TcErrors.reportTidyWanteds does not print the errors
97 and does not fail if -fdefer-type-errors is on, so that we can continue
98 compilation. The errors are turned into warnings in `reportUnsolved`.
99 -}
100
101 -- | Report unsolved goals as errors or warnings. We may also turn some into
102 -- deferred run-time errors if `-fdefer-type-errors` is on.
103 reportUnsolved :: WantedConstraints -> TcM (Bag EvBind)
104 reportUnsolved wanted
105 = do { binds_var <- newTcEvBinds
106 ; defer_errors <- goptM Opt_DeferTypeErrors
107 ; warn_errors <- woptM Opt_WarnDeferredTypeErrors -- implement #10283
108 ; let type_errors | not defer_errors = TypeError
109 | warn_errors = TypeWarn
110 | otherwise = TypeDefer
111
112 ; defer_holes <- goptM Opt_DeferTypedHoles
113 ; warn_holes <- woptM Opt_WarnTypedHoles
114 ; let expr_holes | not defer_holes = HoleError
115 | warn_holes = HoleWarn
116 | otherwise = HoleDefer
117
118 ; partial_sigs <- xoptM Opt_PartialTypeSignatures
119 ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures
120 ; let type_holes | not partial_sigs = HoleError
121 | warn_partial_sigs = HoleWarn
122 | otherwise = HoleDefer
123
124 ; report_unsolved (Just binds_var) False type_errors expr_holes type_holes wanted
125 ; getTcEvBinds binds_var }
126
127 -- | Report *all* unsolved goals as errors, even if -fdefer-type-errors is on
128 -- See Note [Deferring coercion errors to runtime]
129 reportAllUnsolved :: WantedConstraints -> TcM ()
130 reportAllUnsolved wanted
131 = report_unsolved Nothing False TypeError HoleError HoleError wanted
132
133 -- | Report all unsolved goals as warnings (but without deferring any errors to
134 -- run-time). See Note [Safe Haskell Overlapping Instances Implementation] in
135 -- TcSimplify
136 warnAllUnsolved :: WantedConstraints -> TcM ()
137 warnAllUnsolved wanted
138 = report_unsolved Nothing True TypeWarn HoleWarn HoleWarn wanted
139
140 -- | Report unsolved goals as errors or warnings.
141 report_unsolved :: Maybe EvBindsVar -- cec_binds
142 -> Bool -- Errors as warnings
143 -> TypeErrorChoice -- Deferred type errors
144 -> HoleChoice -- Expression holes
145 -> HoleChoice -- Type holes
146 -> WantedConstraints -> TcM ()
147 report_unsolved mb_binds_var err_as_warn type_errors expr_holes type_holes wanted
148 | isEmptyWC wanted
149 = return ()
150 | otherwise
151 = do { traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted)
152
153 ; wanted <- zonkWC wanted -- Zonk to reveal all information
154 ; env0 <- tcInitTidyEnv
155 -- If we are deferring we are going to need /all/ evidence around,
156 -- including the evidence produced by unflattening (zonkWC)
157 ; let tidy_env = tidyFreeTyVars env0 free_tvs
158 free_tvs = tyVarsOfWC wanted
159
160 ; traceTc "reportUnsolved (after zonking and tidying):" $
161 vcat [ pprTvBndrs (varSetElems free_tvs)
162 , ppr wanted ]
163
164 ; warn_redundant <- woptM Opt_WarnRedundantConstraints
165 ; let err_ctxt = CEC { cec_encl = []
166 , cec_tidy = tidy_env
167 , cec_defer_type_errors = type_errors
168 , cec_errors_as_warns = err_as_warn
169 , cec_expr_holes = expr_holes
170 , cec_type_holes = type_holes
171 , cec_suppress = False -- See Note [Suppressing error messages]
172 , cec_warn_redundant = warn_redundant
173 , cec_binds = mb_binds_var }
174
175 ; tc_lvl <- getTcLevel
176 ; reportWanteds err_ctxt tc_lvl wanted }
177
178 --------------------------------------------
179 -- Internal functions
180 --------------------------------------------
181
182 data TypeErrorChoice -- What to do for type errors found by the type checker
183 = TypeError -- A type error aborts compilation with an error message
184 | TypeWarn -- A type error is deferred to runtime, plus a compile-time warning
185 | TypeDefer -- A type error is deferred to runtime; no error or warning at compile time
186
187 data HoleChoice
188 = HoleError -- A hole is a compile-time error
189 | HoleWarn -- Defer to runtime, emit a compile-time warning
190 | HoleDefer -- Defer to runtime, no warning
191
192 data ReportErrCtxt
193 = CEC { cec_encl :: [Implication] -- Enclosing implications
194 -- (innermost first)
195 -- ic_skols and givens are tidied, rest are not
196 , cec_tidy :: TidyEnv
197 , cec_binds :: Maybe EvBindsVar
198 -- Nothinng <=> Report all errors, including holes; no bindings
199 -- Just ev <=> make some errors (depending on cec_defer)
200 -- into warnings, and emit evidence bindings
201 -- into 'ev' for unsolved constraints
202
203 , cec_errors_as_warns :: Bool -- Turn all errors into warnings
204 -- (except for Holes, which are
205 -- controlled by cec_type_holes and
206 -- cec_expr_holes)
207 , cec_defer_type_errors :: TypeErrorChoice -- Defer type errors until runtime
208 -- Irrelevant if cec_binds = Nothing
209
210 , cec_expr_holes :: HoleChoice -- Holes in expressions
211 , cec_type_holes :: HoleChoice -- Holes in types
212
213 , cec_warn_redundant :: Bool -- True <=> -fwarn-redundant-constraints
214
215 , cec_suppress :: Bool -- True <=> More important errors have occurred,
216 -- so create bindings if need be, but
217 -- don't issue any more errors/warnings
218 -- See Note [Suppressing error messages]
219 }
220
221 {-
222 Note [Suppressing error messages]
223 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
224 The cec_suppress flag says "don't report any errors". Instead, just create
225 evidence bindings (as usual). It's used when more important errors have occurred.
226
227 Specifically (see reportWanteds)
228 * If there are insoluble Givens, then we are in unreachable code and all bets
229 are off. So don't report any further errors.
230 * If there are any insolubles (eg Int~Bool), here or in a nested implication,
231 then suppress errors from the simple constraints here. Sometimes the
232 simple-constraint errors are a knock-on effect of the insolubles.
233 -}
234
235 reportImplic :: ReportErrCtxt -> Implication -> TcM ()
236 reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given
237 , ic_wanted = wanted, ic_binds = evb
238 , ic_status = status, ic_info = info
239 , ic_env = tcl_env, ic_tclvl = tc_lvl })
240 | BracketSkol <- info
241 , not insoluble
242 = return () -- For Template Haskell brackets report only
243 -- definite errors. The whole thing will be re-checked
244 -- later when we plug it in, and meanwhile there may
245 -- certainly be un-satisfied constraints
246
247 | otherwise
248 = do { reportWanteds ctxt' tc_lvl wanted
249 ; traceTc "reportImplic" (ppr implic)
250 ; when (cec_warn_redundant ctxt) $
251 warnRedundantConstraints ctxt' tcl_env info' dead_givens }
252 where
253 insoluble = isInsolubleStatus status
254 (env1, tvs') = mapAccumL tidyTyVarBndr (cec_tidy ctxt) tvs
255 (env2, info') = tidySkolemInfo env1 info
256 implic' = implic { ic_skols = tvs'
257 , ic_given = map (tidyEvVar env2) given
258 , ic_info = info' }
259 ctxt' = ctxt { cec_tidy = env2
260 , cec_encl = implic' : cec_encl ctxt
261 , cec_suppress = insoluble -- Suppress inessential errors if there
262 -- are are insolubles anywhere in the
263 -- tree rooted here
264 , cec_binds = case cec_binds ctxt of
265 Nothing -> Nothing
266 Just {} -> Just evb }
267 dead_givens = case status of
268 IC_Solved { ics_dead = dead } -> dead
269 _ -> []
270
271 warnRedundantConstraints :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [EvVar] -> TcM ()
272 warnRedundantConstraints ctxt env info ev_vars
273 | null redundant_evs
274 = return ()
275
276 | SigSkol {} <- info
277 = setLclEnv env $ -- We want to add "In the type signature for f"
278 -- to the error context, which is a bit tiresome
279 addErrCtxt (ptext (sLit "In") <+> ppr info) $
280 do { env <- getLclEnv
281 ; msg <- mkErrorMsg ctxt env doc
282 ; reportWarning msg }
283
284 | otherwise -- But for InstSkol there already *is* a surrounding
285 -- "In the instance declaration for Eq [a]" context
286 -- and we don't want to say it twice. Seems a bit ad-hoc
287 = do { msg <- mkErrorMsg ctxt env doc
288 ; reportWarning msg }
289 where
290 doc = ptext (sLit "Redundant constraint") <> plural redundant_evs <> colon
291 <+> pprEvVarTheta redundant_evs
292
293 redundant_evs = case info of -- See Note [Redundant constraints in instance decls]
294 InstSkol -> filterOut improving ev_vars
295 _ -> ev_vars
296
297 improving ev_var = any isImprovementPred $
298 transSuperClassesPred (idType ev_var)
299
300 {- Note [Redundant constraints in instance decls]
301 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
302 For instance declarations, we don't report unused givens if
303 they can give rise to improvement. Example (Trac #10100):
304 class Add a b ab | a b -> ab, a ab -> b
305 instance Add Zero b b
306 instance Add a b ab => Add (Succ a) b (Succ ab)
307 The context (Add a b ab) for the instance is clearly unused in terms
308 of evidence, since the dictionary has no feilds. But it is still
309 needed! With the context, a wanted constraint
310 Add (Succ Zero) beta (Succ Zero)
311 we will reduce to (Add Zero beta Zero), and thence we get beta := Zero.
312 But without the context we won't find beta := Zero.
313
314 This only matters in instance declarations..
315 -}
316
317 reportWanteds :: ReportErrCtxt -> TcLevel -> WantedConstraints -> TcM ()
318 reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_insol = insols, wc_impl = implics })
319 = do { traceTc "reportWanteds" (vcat [ ptext (sLit "Simples =") <+> ppr simples
320 , ptext (sLit "Suppress =") <+> ppr (cec_suppress ctxt)])
321 ; let tidy_cts = bagToList (mapBag (tidyCt env) (insols `unionBags` simples))
322
323 -- First deal with things that are utterly wrong
324 -- Like Int ~ Bool (incl nullary TyCons)
325 -- or Int ~ t a (AppTy on one side)
326 -- These ones are not suppressed by the incoming context
327 ; let ctxt_for_insols = ctxt { cec_suppress = False }
328 ; (ctxt1, cts1) <- tryReporters ctxt_for_insols report1 tidy_cts
329
330 -- Now all the other constraints. We suppress errors here if
331 -- any of the first batch failed, or if the enclosing context
332 -- says to suppress
333 ; let ctxt2 = ctxt { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 }
334 ; (_, leftovers) <- tryReporters ctxt2 report2 cts1
335 ; MASSERT2( null leftovers, ppr leftovers )
336
337 -- All the Derived ones have been filtered out of simples
338 -- by the constraint solver. This is ok; we don't want
339 -- to report unsolved Derived goals as errors
340 -- See Note [Do not report derived but soluble errors]
341
342 ; mapBagM_ (reportImplic ctxt2) implics }
343 -- NB ctxt1: don't suppress inner insolubles if there's only a
344 -- wanted insoluble here; but do suppress inner insolubles
345 -- if there's a *given* insoluble here (= inaccessible code)
346 where
347 env = cec_tidy ctxt
348
349 -- report1: ones that should *not* be suppresed by
350 -- an insoluble somewhere else in the tree
351 -- It's crucial that anything that is considered insoluble
352 -- (see TcRnTypes.trulyInsoluble) is caught here, otherwise
353 -- we might suppress its error message, and proceed on past
354 -- type checking to get a Lint error later
355 report1 = [ ("custom_error", is_user_type_error,
356 True, mkUserTypeErrorReporter)
357 , ("insoluble1", is_given, True, mkGroupReporter mkEqErr)
358 , ("insoluble2", utterly_wrong, True, mkGroupReporter mkEqErr)
359 , ("insoluble3", rigid_nom_tv_eq, True, mkSkolReporter)
360 , ("insoluble4", rigid_nom_eq, True, mkGroupReporter mkEqErr)
361 , ("Out of scope", is_out_of_scope, True, mkHoleReporter)
362 , ("Holes", is_hole, False, mkHoleReporter)
363
364 -- The only remaining equalities are alpha ~ ty,
365 -- where alpha is untouchable; and representational equalities
366 , ("Other eqs", is_equality, False, mkGroupReporter mkEqErr) ]
367
368 -- report2: we suppress these if there are insolubles elsewhere in the tree
369 report2 = [ ("Implicit params", is_ip, False, mkGroupReporter mkIPErr)
370 , ("Irreds", is_irred, False, mkGroupReporter mkIrredErr)
371 , ("Dicts", is_dict, False, mkGroupReporter mkDictErr) ]
372
373 rigid_nom_eq, rigid_nom_tv_eq, is_hole, is_dict,
374 is_equality, is_ip, is_irred :: Ct -> PredTree -> Bool
375
376 utterly_wrong _ (EqPred NomEq ty1 ty2) = isRigidTy ty1 && isRigidTy ty2
377 utterly_wrong _ _ = False
378
379 is_out_of_scope ct _ = isOutOfScopeCt ct
380 is_hole ct _ = isHoleCt ct
381 is_user_type_error ct _ = isUserTypeErrorCt ct
382 is_given ct _ = not (isWantedCt ct) -- The Derived ones are actually all from Givens
383
384 -- Skolem (i.e. non-meta) type variable on the left
385 rigid_nom_eq _ pred = isRigidEqPred tc_lvl pred
386
387 rigid_nom_tv_eq _ pred
388 | EqPred _ ty1 _ <- pred = isRigidEqPred tc_lvl pred && isTyVarTy ty1
389 | otherwise = False
390
391 is_equality _ (EqPred {}) = True
392 is_equality _ _ = False
393
394 is_dict _ (ClassPred {}) = True
395 is_dict _ _ = False
396
397 is_ip _ (ClassPred cls _) = isIPClass cls
398 is_ip _ _ = False
399
400 is_irred _ (IrredPred {}) = True
401 is_irred _ _ = False
402
403
404 ---------------
405 isTyFun_maybe :: Type -> Maybe TyCon
406 isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of
407 Just (tc,_) | isTypeFamilyTyCon tc -> Just tc
408 _ -> Nothing
409
410
411 --------------------------------------------
412 -- Reporters
413 --------------------------------------------
414
415 type Reporter
416 = ReportErrCtxt -> [Ct] -> TcM ()
417 type ReporterSpec
418 = ( String -- Name
419 , Ct -> PredTree -> Bool -- Pick these ones
420 , Bool -- True <=> suppress subsequent reporters
421 , Reporter) -- The reporter itself
422
423 mkSkolReporter :: Reporter
424 -- Suppress duplicates with the same LHS
425 mkSkolReporter ctxt cts
426 = mapM_ (reportGroup mkEqErr ctxt) (equivClasses cmp_lhs_type cts)
427 where
428 cmp_lhs_type ct1 ct2
429 = case (classifyPredType (ctPred ct1), classifyPredType (ctPred ct2)) of
430 (EqPred eq_rel1 ty1 _, EqPred eq_rel2 ty2 _) ->
431 (eq_rel1 `compare` eq_rel2) `thenCmp` (ty1 `cmpType` ty2)
432 _ -> pprPanic "mkSkolReporter" (ppr ct1 $$ ppr ct2)
433
434 mkHoleReporter :: Reporter
435 -- Reports errors one at a time
436 mkHoleReporter ctxt
437 = mapM_ $ \ct ->
438 do { err <- mkHoleError ctxt ct
439 ; maybeReportHoleError ctxt ct err
440 ; maybeAddDeferredHoleBinding ctxt err ct }
441
442 mkUserTypeErrorReporter :: Reporter
443 mkUserTypeErrorReporter ctxt
444 = mapM_ $ \ct -> maybeReportError ctxt =<< mkUserTypeError ctxt ct
445
446 mkUserTypeError :: ReportErrCtxt -> Ct -> TcM ErrMsg
447 mkUserTypeError ctxt ct = mkErrorMsgFromCt ctxt ct
448 $ pprUserTypeErrorTy
449 $ case getUserTypeErrorMsg ct of
450 Just (_,msg) -> msg
451 Nothing -> pprPanic "mkUserTypeError" (ppr ct)
452
453
454 mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg)
455 -- Make error message for a group
456 -> Reporter -- Deal with lots of constraints
457 -- Group together errors from same location,
458 -- and report only the first (to avoid a cascade)
459 mkGroupReporter mk_err ctxt cts
460 = mapM_ (reportGroup mk_err ctxt) (equivClasses cmp_loc cts)
461 where
462 cmp_loc ct1 ct2 = ctLocSpan (ctLoc ct1) `compare` ctLocSpan (ctLoc ct2)
463
464 reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> ReportErrCtxt
465 -> [Ct] -> TcM ()
466 reportGroup mk_err ctxt cts =
467 case partition isMonadFailInstanceMissing cts of
468 -- Only warn about missing MonadFail constraint when
469 -- there are no other missing contstraints!
470 (monadFailCts, []) -> do { err <- mk_err ctxt monadFailCts
471 ; reportWarning err }
472
473 (_, cts') -> do { err <- mk_err ctxt cts'
474 ; maybeReportError ctxt err
475 ; mapM_ (maybeAddDeferredBinding ctxt err) cts' }
476 -- Add deferred bindings for all
477 -- But see Note [Always warn with -fdefer-type-errors]
478 where
479 isMonadFailInstanceMissing ct =
480 case ctLocOrigin (ctLoc ct) of
481 FailablePattern _pat -> True
482 _otherwise -> False
483
484 maybeReportHoleError :: ReportErrCtxt -> Ct -> ErrMsg -> TcM ()
485 maybeReportHoleError ctxt ct err
486 -- When -XPartialTypeSignatures is on, warnings (instead of errors) are
487 -- generated for holes in partial type signatures. Unless
488 -- -fwarn_partial_type_signatures is not on, in which case the messages are
489 -- discarded.
490 | isTypeHoleCt ct
491 = -- For partial type signatures, generate warnings only, and do that
492 -- only if -fwarn_partial_type_signatures is on
493 case cec_type_holes ctxt of
494 HoleError -> reportError err
495 HoleWarn -> reportWarning err
496 HoleDefer -> return ()
497
498 -- Otherwise this is a typed hole in an expression
499 | otherwise
500 = -- If deferring, report a warning only if -fwarn-typed-holds is on
501 case cec_expr_holes ctxt of
502 HoleError -> reportError err
503 HoleWarn -> reportWarning err
504 HoleDefer -> return ()
505
506 maybeReportError :: ReportErrCtxt -> ErrMsg -> TcM ()
507 -- Report the error and/or make a deferred binding for it
508 maybeReportError ctxt err
509 | cec_errors_as_warns ctxt
510 = reportWarning err
511 | otherwise
512 = case cec_defer_type_errors ctxt of
513 TypeDefer -> return ()
514 TypeWarn -> reportWarning err
515 -- handle case when suppress is on like in the original code
516 TypeError -> if cec_suppress ctxt then return () else reportError err
517
518 addDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
519 -- See Note [Deferring coercion errors to runtime]
520 addDeferredBinding ctxt err ct
521 | CtWanted { ctev_pred = pred, ctev_evar = ev_id } <- ctEvidence ct
522 -- Only add deferred bindings for Wanted constraints
523 , Just ev_binds_var <- cec_binds ctxt -- We have somewhere to put the bindings
524 = do { dflags <- getDynFlags
525 ; let err_msg = pprLocErrMsg err
526 err_fs = mkFastString $ showSDoc dflags $
527 err_msg $$ text "(deferred type error)"
528
529 -- Create the binding
530 ; addTcEvBind ev_binds_var (mkWantedEvBind ev_id (EvDelayedError pred err_fs)) }
531
532 | otherwise -- Do not set any evidence for Given/Derived
533 = return ()
534
535 maybeAddDeferredHoleBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
536 maybeAddDeferredHoleBinding ctxt err ct
537 | isExprHoleCt ct
538 , case cec_expr_holes ctxt of
539 HoleDefer -> True
540 HoleWarn -> True
541 HoleError -> False
542 = addDeferredBinding ctxt err ct -- Only add bindings for holes in expressions
543 | otherwise -- not for holes in partial type signatures
544 = return ()
545
546 maybeAddDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
547 maybeAddDeferredBinding ctxt err ct =
548 case cec_defer_type_errors ctxt of
549 TypeDefer -> deferred
550 TypeWarn -> deferred
551 TypeError -> return ()
552 where
553 deferred = addDeferredBinding ctxt err ct
554
555 tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct])
556 -- Use the first reporter in the list whose predicate says True
557 tryReporters ctxt reporters cts
558 = do { traceTc "tryReporters {" (ppr cts)
559 ; (ctxt', cts') <- go ctxt reporters cts
560 ; traceTc "tryReporters }" (ppr cts')
561 ; return (ctxt', cts') }
562 where
563 go ctxt [] cts
564 = return (ctxt, cts)
565
566 go ctxt (r : rs) cts
567 = do { (ctxt', cts') <- tryReporter ctxt r cts
568 ; go ctxt' rs cts' }
569 -- Carry on with the rest, because we must make
570 -- deferred bindings for them if we have -fdefer-type-errors
571 -- But suppress their error messages
572
573 tryReporter :: ReportErrCtxt -> ReporterSpec -> [Ct] -> TcM (ReportErrCtxt, [Ct])
574 tryReporter ctxt (str, keep_me, suppress_after, reporter) cts
575 | null yeses = return (ctxt, cts)
576 | otherwise = do { traceTc "tryReporter:" (text str <+> ppr yeses)
577 ; reporter ctxt yeses
578 ; let ctxt' = ctxt { cec_suppress = suppress_after || cec_suppress ctxt }
579 ; return (ctxt', nos) }
580 where
581 (yeses, nos) = partition (\ct -> keep_me ct (classifyPredType (ctPred ct))) cts
582
583
584 pprArising :: CtOrigin -> SDoc
585 -- Used for the main, top-level error message
586 -- We've done special processing for TypeEq, KindEq, Given
587 pprArising (TypeEqOrigin {}) = empty
588 pprArising (KindEqOrigin {}) = empty
589 pprArising (GivenOrigin {}) = empty
590 pprArising orig = pprCtOrigin orig
591
592 -- Add the "arising from..." part to a message about bunch of dicts
593 addArising :: CtOrigin -> SDoc -> SDoc
594 addArising orig msg = hang msg 2 (pprArising orig)
595
596 pprWithArising :: [Ct] -> (CtLoc, SDoc)
597 -- Print something like
598 -- (Eq a) arising from a use of x at y
599 -- (Show a) arising from a use of p at q
600 -- Also return a location for the error message
601 -- Works for Wanted/Derived only
602 pprWithArising []
603 = panic "pprWithArising"
604 pprWithArising (ct:cts)
605 | null cts
606 = (loc, addArising (ctLocOrigin loc)
607 (pprTheta [ctPred ct]))
608 | otherwise
609 = (loc, vcat (map ppr_one (ct:cts)))
610 where
611 loc = ctLoc ct
612 ppr_one ct' = hang (parens (pprType (ctPred ct')))
613 2 (pprCtLoc (ctLoc ct'))
614
615 mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> SDoc -> TcM ErrMsg
616 mkErrorMsgFromCt ctxt ct msg
617 = mkErrorMsg ctxt (ctLocEnv (ctLoc ct)) msg
618
619 mkErrorMsg :: ReportErrCtxt -> TcLclEnv -> SDoc -> TcM ErrMsg
620 mkErrorMsg ctxt tcl_env msg
621 = do { err_info <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)
622 ; mkLongErrAt (RealSrcSpan (tcl_loc tcl_env)) msg err_info }
623
624 type UserGiven = ([EvVar], SkolemInfo, Bool, RealSrcSpan)
625
626 getUserGivens :: ReportErrCtxt -> [UserGiven]
627 -- One item for each enclosing implication
628 getUserGivens (CEC {cec_encl = ctxt})
629 = reverse $
630 [ (givens, info, no_eqs, tcl_loc env)
631 | Implic { ic_given = givens, ic_env = env
632 , ic_no_eqs = no_eqs, ic_info = info } <- ctxt
633 , not (null givens) ]
634
635 {-
636 Note [Always warn with -fdefer-type-errors]
637 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
638 When -fdefer-type-errors is on we warn about *all* type errors, even
639 if cec_suppress is on. This can lead to a lot more warnings than you
640 would get errors without -fdefer-type-errors, but if we suppress any of
641 them you might get a runtime error that wasn't warned about at compile
642 time.
643
644 This is an easy design choice to change; just flip the order of the
645 first two equations for maybeReportError
646
647 To be consistent, we should also report multiple warnings from a single
648 location in mkGroupReporter, when -fdefer-type-errors is on. But that
649 is perhaps a bit *over*-consistent! Again, an easy choice to change.
650
651 With #10283, you can now opt out of deferred type error warnings.
652
653
654 Note [Do not report derived but soluble errors]
655 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
656 The wc_simples include Derived constraints that have not been solved, but are
657 not insoluble (in that case they'd be in wc_insols). We do not want to report
658 these as errors:
659
660 * Superclass constraints. If we have an unsolved [W] Ord a, we'll also have
661 an unsolved [D] Eq a, and we do not want to report that; it's just noise.
662
663 * Functional dependencies. For givens, consider
664 class C a b | a -> b
665 data T a where
666 MkT :: C a d => [d] -> T a
667 f :: C a b => T a -> F Int
668 f (MkT xs) = length xs
669 Then we get a [D] b~d. But there *is* a legitimate call to
670 f, namely f (MkT [True]) :: T Bool, in which b=d. So we should
671 not reject the program.
672
673 For wanteds, something similar
674 data T a where
675 MkT :: C Int b => a -> b -> T a
676 g :: C Int c => c -> ()
677 f :: T a -> ()
678 f (MkT x y) = g x
679 Here we get [G] C Int b, [W] C Int a, hence [D] a~b.
680 But again f (MkT True True) is a legitimate call.
681
682 (We leave the Deriveds in wc_simple until reportErrors, so that we don't lose
683 derived superclasses between iterations of the solver.)
684
685 For functional dependencies, here is a real example,
686 stripped off from libraries/utf8-string/Codec/Binary/UTF8/Generic.hs
687
688 class C a b | a -> b
689 g :: C a b => a -> b -> ()
690 f :: C a b => a -> b -> ()
691 f xa xb =
692 let loop = g xa
693 in loop xb
694
695 We will first try to infer a type for loop, and we will succeed:
696 C a b' => b' -> ()
697 Subsequently, we will type check (loop xb) and all is good. But,
698 recall that we have to solve a final implication constraint:
699 C a b => (C a b' => .... cts from body of loop .... ))
700 And now we have a problem as we will generate an equality b ~ b' and fail to
701 solve it.
702
703
704 ************************************************************************
705 * *
706 Irreducible predicate errors
707 * *
708 ************************************************************************
709 -}
710
711 mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
712 mkIrredErr ctxt cts
713 = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1
714 ; let orig = ctOrigin ct1
715 msg = couldNotDeduce (getUserGivens ctxt) (map ctPred cts, orig)
716 ; mkErrorMsgFromCt ctxt ct1 (msg $$ binds_msg) }
717 where
718 (ct1:_) = cts
719
720 ----------------
721 mkHoleError :: ReportErrCtxt -> Ct -> TcM ErrMsg
722 mkHoleError ctxt ct@(CHoleCan { cc_occ = occ, cc_hole = hole_sort })
723 | isOutOfScopeCt ct -- Out of scope variables, like 'a', where 'a' isn't bound
724 -- Suggest possible in-scope variables in the message
725 = do { dflags <- getDynFlags
726 ; rdr_env <- getGlobalRdrEnv
727 ; mkLongErrAt (RealSrcSpan (tcl_loc lcl_env)) out_of_scope_msg
728 (unknownNameSuggestions dflags rdr_env
729 (tcl_rdr lcl_env) (mkRdrUnqual occ)) }
730
731 | otherwise -- Explicit holes, like "_" or "_f"
732 = do { (ctxt, binds_doc, ct) <- relevantBindings False ctxt ct
733 -- The 'False' means "don't filter the bindings"; see Trac #8191
734 ; mkErrorMsgFromCt ctxt ct (hole_msg $$ binds_doc) }
735
736 where
737 ct_loc = ctLoc ct
738 lcl_env = ctLocEnv ct_loc
739 hole_ty = ctEvPred (ctEvidence ct)
740 tyvars = varSetElems (tyVarsOfType hole_ty)
741 boring_type = isTyVarTy hole_ty
742
743 out_of_scope_msg -- Print v :: ty only if the type has structure
744 | boring_type = hang herald 2 (ppr occ)
745 | otherwise = hang herald 2 pp_with_type
746
747 pp_with_type = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType hole_ty)
748 herald | isDataOcc occ = ptext (sLit "Data constructor not in scope:")
749 | otherwise = ptext (sLit "Variable not in scope:")
750
751 hole_msg = case hole_sort of
752 ExprHole -> vcat [ hang (ptext (sLit "Found hole:"))
753 2 pp_with_type
754 , tyvars_msg, expr_hole_hint ]
755 TypeHole -> vcat [ hang (ptext (sLit "Found type wildcard") <+> quotes (ppr occ))
756 2 (ptext (sLit "standing for") <+> quotes (pprType hole_ty))
757 , tyvars_msg, type_hole_hint ]
758
759 tyvars_msg = ppUnless (null tyvars) $
760 ptext (sLit "Where:") <+> vcat (map loc_msg tyvars)
761
762 type_hole_hint
763 | HoleError <- cec_type_holes ctxt
764 = ptext (sLit "To use the inferred type, enable PartialTypeSignatures")
765 | otherwise
766 = empty
767
768 expr_hole_hint -- Give hint for, say, f x = _x
769 | lengthFS (occNameFS occ) > 1 -- Don't give this hint for plain "_"
770 = ptext (sLit "Or perhaps") <+> quotes (ppr occ)
771 <+> ptext (sLit "is mis-spelled, or not in scope")
772 | otherwise
773 = empty
774
775 loc_msg tv
776 = case tcTyVarDetails tv of
777 SkolemTv {} -> quotes (ppr tv) <+> skol_msg
778 MetaTv {} -> quotes (ppr tv) <+> ptext (sLit "is an ambiguous type variable")
779 det -> pprTcTyVarDetails det
780 where
781 skol_msg = pprSkol (getSkolemInfo (cec_encl ctxt) tv) (getSrcLoc tv)
782
783 mkHoleError _ ct = pprPanic "mkHoleError" (ppr ct)
784
785 ----------------
786 mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
787 mkIPErr ctxt cts
788 = do { (ctxt, bind_msg, ct1) <- relevantBindings True ctxt ct1
789 ; let orig = ctOrigin ct1
790 preds = map ctPred cts
791 givens = getUserGivens ctxt
792 msg | null givens
793 = addArising orig $
794 sep [ ptext (sLit "Unbound implicit parameter") <> plural cts
795 , nest 2 (pprTheta preds) ]
796 | otherwise
797 = couldNotDeduce givens (preds, orig)
798
799 ; mkErrorMsgFromCt ctxt ct1 (msg $$ bind_msg) }
800 where
801 (ct1:_) = cts
802
803 {-
804 ************************************************************************
805 * *
806 Equality errors
807 * *
808 ************************************************************************
809
810 Note [Inaccessible code]
811 ~~~~~~~~~~~~~~~~~~~~~~~~
812 Consider
813 data T a where
814 T1 :: T a
815 T2 :: T Bool
816
817 f :: (a ~ Int) => T a -> Int
818 f T1 = 3
819 f T2 = 4 -- Unreachable code
820
821 Here the second equation is unreachable. The original constraint
822 (a~Int) from the signature gets rewritten by the pattern-match to
823 (Bool~Int), so the danger is that we report the error as coming from
824 the *signature* (Trac #7293). So, for Given errors we replace the
825 env (and hence src-loc) on its CtLoc with that from the immediately
826 enclosing implication.
827 -}
828
829 mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
830 -- Don't have multiple equality errors from the same location
831 -- E.g. (Int,Bool) ~ (Bool,Int) one error will do!
832 mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct
833 mkEqErr _ [] = panic "mkEqErr"
834
835 mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg
836 -- Wanted constraints only!
837 mkEqErr1 ctxt ct
838 | isGivenCt ct
839 = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
840 ; let (given_loc, given_msg) = mk_given (ctLoc ct) (cec_encl ctxt)
841 ; dflags <- getDynFlags
842 ; mkEqErr_help dflags ctxt (given_msg $$ binds_msg)
843 (setCtLoc ct given_loc) -- Note [Inaccessible code]
844 Nothing ty1 ty2 }
845
846 | otherwise -- Wanted or derived
847 = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
848 ; rdr_env <- getGlobalRdrEnv
849 ; fam_envs <- tcGetFamInstEnvs
850 ; exp_syns <- goptM Opt_PrintExpandedSynonyms
851 ; let (is_oriented, wanted_msg) = mk_wanted_extra (ctOrigin ct) exp_syns
852 coercible_msg = case ctEqRel ct of
853 NomEq -> empty
854 ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2
855 ; dflags <- getDynFlags
856 ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctOrigin ct))
857 ; mkEqErr_help dflags ctxt (wanted_msg $$ coercible_msg $$ binds_msg)
858 ct is_oriented ty1 ty2 }
859 where
860 (ty1, ty2) = getEqPredTys (ctPred ct)
861
862 mk_given :: CtLoc -> [Implication] -> (CtLoc, SDoc)
863 -- For given constraints we overwrite the env (and hence src-loc)
864 -- with one from the implication. See Note [Inaccessible code]
865 mk_given loc [] = (loc, empty)
866 mk_given loc (implic : _) = (setCtLocEnv loc (ic_env implic)
867 , hang (ptext (sLit "Inaccessible code in"))
868 2 (ppr (ic_info implic)))
869
870 -- If the types in the error message are the same as the types
871 -- we are unifying, don't add the extra expected/actual message
872 mk_wanted_extra :: CtOrigin -> Bool -> (Maybe SwapFlag, SDoc)
873 mk_wanted_extra orig@(TypeEqOrigin {}) expandSyns
874 = mkExpectedActualMsg ty1 ty2 orig expandSyns
875
876 mk_wanted_extra (KindEqOrigin cty1 cty2 sub_o) expandSyns
877 = (Nothing, msg1 $$ msg2)
878 where
879 msg1 = hang (ptext (sLit "When matching types"))
880 2 (vcat [ ppr cty1 <+> dcolon <+> ppr (typeKind cty1)
881 , ppr cty2 <+> dcolon <+> ppr (typeKind cty2) ])
882 msg2 = case sub_o of
883 TypeEqOrigin {} ->
884 snd (mkExpectedActualMsg cty1 cty2 sub_o expandSyns)
885 _ ->
886 empty
887
888 mk_wanted_extra _ _ = (Nothing, empty)
889
890 -- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint
891 -- is left over.
892 mkCoercibleExplanation :: GlobalRdrEnv -> FamInstEnvs
893 -> TcType -> TcType -> SDoc
894 mkCoercibleExplanation rdr_env fam_envs ty1 ty2
895 | Just (tc, tys) <- tcSplitTyConApp_maybe ty1
896 , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys
897 , Just msg <- coercible_msg_for_tycon rep_tc
898 = msg
899 | Just (tc, tys) <- splitTyConApp_maybe ty2
900 , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys
901 , Just msg <- coercible_msg_for_tycon rep_tc
902 = msg
903 | Just (s1, _) <- tcSplitAppTy_maybe ty1
904 , Just (s2, _) <- tcSplitAppTy_maybe ty2
905 , s1 `eqType` s2
906 , has_unknown_roles s1
907 = hang (text "NB: We cannot know what roles the parameters to" <+>
908 quotes (ppr s1) <+> text "have;")
909 2 (text "we must assume that the role is nominal")
910 | otherwise
911 = empty
912 where
913 coercible_msg_for_tycon tc
914 | isAbstractTyCon tc
915 = Just $ hsep [ text "NB: The type constructor"
916 , quotes (pprSourceTyCon tc)
917 , text "is abstract" ]
918 | isNewTyCon tc
919 , [data_con] <- tyConDataCons tc
920 , let dc_name = dataConName data_con
921 , null (lookupGRE_Name rdr_env dc_name)
922 = Just $ hang (text "The data constructor" <+> quotes (ppr dc_name))
923 2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc)
924 , text "is not in scope" ])
925 | otherwise = Nothing
926
927 has_unknown_roles ty
928 | Just (tc, tys) <- tcSplitTyConApp_maybe ty
929 = length tys >= tyConArity tc -- oversaturated tycon
930 | Just (s, _) <- tcSplitAppTy_maybe ty
931 = has_unknown_roles s
932 | isTyVarTy ty
933 = True
934 | otherwise
935 = False
936
937 {-
938 -- | Make a listing of role signatures for all the parameterised tycons
939 -- used in the provided types
940
941
942 -- SLPJ Jun 15: I could not convince myself that these hints were really
943 -- useful. Maybe they are, but I think we need more work to make them
944 -- actually helpful.
945 mkRoleSigs :: Type -> Type -> SDoc
946 mkRoleSigs ty1 ty2
947 = ppUnless (null role_sigs) $
948 hang (text "Relevant role signatures:")
949 2 (vcat role_sigs)
950 where
951 tcs = nameEnvElts $ tyConsOfType ty1 `plusNameEnv` tyConsOfType ty2
952 role_sigs = mapMaybe ppr_role_sig tcs
953
954 ppr_role_sig tc
955 | null roles -- if there are no parameters, don't bother printing
956 = Nothing
957 | otherwise
958 = Just $ hsep $ [text "type role", ppr tc] ++ map ppr roles
959 where
960 roles = tyConRoles tc
961 -}
962
963 mkEqErr_help :: DynFlags -> ReportErrCtxt -> SDoc
964 -> Ct
965 -> Maybe SwapFlag -- Nothing <=> not sure
966 -> TcType -> TcType -> TcM ErrMsg
967 mkEqErr_help dflags ctxt extra ct oriented ty1 ty2
968 | Just tv1 <- tcGetTyVar_maybe ty1 = mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2
969 | Just tv2 <- tcGetTyVar_maybe ty2 = mkTyVarEqErr dflags ctxt extra ct swapped tv2 ty1
970 | otherwise = reportEqErr ctxt extra ct oriented ty1 ty2
971 where
972 swapped = fmap flipSwap oriented
973
974 reportEqErr :: ReportErrCtxt -> SDoc
975 -> Ct
976 -> Maybe SwapFlag -- Nothing <=> not sure
977 -> TcType -> TcType -> TcM ErrMsg
978 reportEqErr ctxt extra1 ct oriented ty1 ty2
979 = do { let extra2 = mkEqInfoMsg ct ty1 ty2
980 ; mkErrorMsgFromCt ctxt ct (vcat [ misMatchOrCND ctxt ct oriented ty1 ty2
981 , extra2, extra1]) }
982
983 mkTyVarEqErr :: DynFlags -> ReportErrCtxt -> SDoc -> Ct
984 -> Maybe SwapFlag -> TcTyVar -> TcType -> TcM ErrMsg
985 -- tv1 and ty2 are already tidied
986 mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2
987 | isUserSkolem ctxt tv1 -- ty2 won't be a meta-tyvar, or else the thing would
988 -- be oriented the other way round;
989 -- see TcCanonical.canEqTyVarTyVar
990 || isSigTyVar tv1 && not (isTyVarTy ty2)
991 || ctEqRel ct == ReprEq && not (isTyVarUnderDatatype tv1 ty2)
992 -- the cases below don't really apply to ReprEq (except occurs check)
993 = mkErrorMsgFromCt ctxt ct (vcat [ misMatchOrCND ctxt ct oriented ty1 ty2
994 , extraTyVarInfo ctxt tv1 ty2
995 , extra ])
996
997 -- So tv is a meta tyvar (or started that way before we
998 -- generalised it). So presumably it is an *untouchable*
999 -- meta tyvar or a SigTv, else it'd have been unified
1000 | not (k2 `tcIsSubKind` k1) -- Kind error
1001 = mkErrorMsgFromCt ctxt ct $ (kindErrorMsg (mkTyVarTy tv1) ty2 $$ extra)
1002
1003 | OC_Occurs <- occ_check_expand
1004 , ctEqRel ct == NomEq || isTyVarUnderDatatype tv1 ty2
1005 -- See Note [Occurs check error] in TcCanonical
1006 = do { let occCheckMsg = addArising (ctOrigin ct) $
1007 hang (text "Occurs check: cannot construct the infinite type:")
1008 2 (sep [ppr ty1, char '~', ppr ty2])
1009 extra2 = mkEqInfoMsg ct ty1 ty2
1010 ; mkErrorMsgFromCt ctxt ct (occCheckMsg $$ extra2 $$ extra) }
1011
1012 | OC_Forall <- occ_check_expand
1013 = do { let msg = vcat [ ptext (sLit "Cannot instantiate unification variable")
1014 <+> quotes (ppr tv1)
1015 , hang (ptext (sLit "with a type involving foralls:")) 2 (ppr ty2)
1016 , nest 2 (ptext (sLit "GHC doesn't yet support impredicative polymorphism")) ]
1017 ; mkErrorMsgFromCt ctxt ct msg }
1018
1019 -- If the immediately-enclosing implication has 'tv' a skolem, and
1020 -- we know by now its an InferSkol kind of skolem, then presumably
1021 -- it started life as a SigTv, else it'd have been unified, given
1022 -- that there's no occurs-check or forall problem
1023 | (implic:_) <- cec_encl ctxt
1024 , Implic { ic_skols = skols } <- implic
1025 , tv1 `elem` skols
1026 = mkErrorMsgFromCt ctxt ct (vcat [ misMatchMsg ct oriented ty1 ty2
1027 , extraTyVarInfo ctxt tv1 ty2
1028 , extra ])
1029
1030 -- Check for skolem escape
1031 | (implic:_) <- cec_encl ctxt -- Get the innermost context
1032 , Implic { ic_env = env, ic_skols = skols, ic_info = skol_info } <- implic
1033 , let esc_skols = filter (`elemVarSet` (tyVarsOfType ty2)) skols
1034 , not (null esc_skols)
1035 = do { let msg = misMatchMsg ct oriented ty1 ty2
1036 esc_doc = sep [ ptext (sLit "because type variable") <> plural esc_skols
1037 <+> pprQuotedList esc_skols
1038 , ptext (sLit "would escape") <+>
1039 if isSingleton esc_skols then ptext (sLit "its scope")
1040 else ptext (sLit "their scope") ]
1041 tv_extra = vcat [ nest 2 $ esc_doc
1042 , sep [ (if isSingleton esc_skols
1043 then ptext (sLit "This (rigid, skolem) type variable is")
1044 else ptext (sLit "These (rigid, skolem) type variables are"))
1045 <+> ptext (sLit "bound by")
1046 , nest 2 $ ppr skol_info
1047 , nest 2 $ ptext (sLit "at") <+> ppr (tcl_loc env) ] ]
1048 ; mkErrorMsgFromCt ctxt ct (msg $$ tv_extra $$ extra) }
1049
1050 -- Nastiest case: attempt to unify an untouchable variable
1051 | (implic:_) <- cec_encl ctxt -- Get the innermost context
1052 , Implic { ic_env = env, ic_given = given, ic_info = skol_info } <- implic
1053 = do { let msg = misMatchMsg ct oriented ty1 ty2
1054 tclvl_extra
1055 = nest 2 $
1056 sep [ quotes (ppr tv1) <+> ptext (sLit "is untouchable")
1057 , nest 2 $ ptext (sLit "inside the constraints:") <+> pprEvVarTheta given
1058 , nest 2 $ ptext (sLit "bound by") <+> ppr skol_info
1059 , nest 2 $ ptext (sLit "at") <+> ppr (tcl_loc env) ]
1060 tv_extra = extraTyVarInfo ctxt tv1 ty2
1061 add_sig = suggestAddSig ctxt ty1 ty2
1062 ; mkErrorMsgFromCt ctxt ct (vcat [msg, tclvl_extra, tv_extra, add_sig, extra]) }
1063
1064 | otherwise
1065 = reportEqErr ctxt extra ct oriented (mkTyVarTy tv1) ty2
1066 -- This *can* happen (Trac #6123, and test T2627b)
1067 -- Consider an ambiguous top-level constraint (a ~ F a)
1068 -- Not an occurs check, because F is a type function.
1069 where
1070 occ_check_expand = occurCheckExpand dflags tv1 ty2
1071 k1 = tyVarKind tv1
1072 k2 = typeKind ty2
1073 ty1 = mkTyVarTy tv1
1074
1075 mkEqInfoMsg :: Ct -> TcType -> TcType -> SDoc
1076 -- Report (a) ambiguity if either side is a type function application
1077 -- e.g. F a0 ~ Int
1078 -- (b) warning about injectivity if both sides are the same
1079 -- type function application F a ~ F b
1080 -- See Note [Non-injective type functions]
1081 mkEqInfoMsg ct ty1 ty2
1082 = tyfun_msg $$ ambig_msg
1083 where
1084 mb_fun1 = isTyFun_maybe ty1
1085 mb_fun2 = isTyFun_maybe ty2
1086
1087 ambig_msg | isJust mb_fun1 || isJust mb_fun2
1088 = snd (mkAmbigMsg False ct)
1089 | otherwise = empty
1090
1091 tyfun_msg | Just tc1 <- mb_fun1
1092 , Just tc2 <- mb_fun2
1093 , tc1 == tc2
1094 = ptext (sLit "NB:") <+> quotes (ppr tc1)
1095 <+> ptext (sLit "is a type function, and may not be injective")
1096 | otherwise = empty
1097
1098 isUserSkolem :: ReportErrCtxt -> TcTyVar -> Bool
1099 -- See Note [Reporting occurs-check errors]
1100 isUserSkolem ctxt tv
1101 = isSkolemTyVar tv && any is_user_skol_tv (cec_encl ctxt)
1102 where
1103 is_user_skol_tv (Implic { ic_skols = sks, ic_info = skol_info })
1104 = tv `elem` sks && is_user_skol_info skol_info
1105
1106 is_user_skol_info (InferSkol {}) = False
1107 is_user_skol_info _ = True
1108
1109 misMatchOrCND :: ReportErrCtxt -> Ct -> Maybe SwapFlag -> TcType -> TcType -> SDoc
1110 -- If oriented then ty1 is actual, ty2 is expected
1111 misMatchOrCND ctxt ct oriented ty1 ty2
1112 | null givens ||
1113 (isRigidTy ty1 && isRigidTy ty2) ||
1114 isGivenCt ct
1115 -- If the equality is unconditionally insoluble
1116 -- or there is no context, don't report the context
1117 = misMatchMsg ct oriented ty1 ty2
1118 | otherwise
1119 = couldNotDeduce givens ([eq_pred], orig)
1120 where
1121 ev = ctEvidence ct
1122 eq_pred = ctEvPred ev
1123 orig = ctEvOrigin ev
1124 givens = [ given | given@(_, _, no_eqs, _) <- getUserGivens ctxt, not no_eqs]
1125 -- Keep only UserGivens that have some equalities
1126
1127 couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc
1128 couldNotDeduce givens (wanteds, orig)
1129 = vcat [ addArising orig (ptext (sLit "Could not deduce:") <+> pprTheta wanteds)
1130 , vcat (pp_givens givens)]
1131
1132 pp_givens :: [UserGiven] -> [SDoc]
1133 pp_givens givens
1134 = case givens of
1135 [] -> []
1136 (g:gs) -> ppr_given (ptext (sLit "from the context:")) g
1137 : map (ppr_given (ptext (sLit "or from:"))) gs
1138 where
1139 ppr_given herald (gs, skol_info, _, loc)
1140 = hang (herald <+> pprEvVarTheta gs)
1141 2 (sep [ ptext (sLit "bound by") <+> ppr skol_info
1142 , ptext (sLit "at") <+> ppr loc])
1143
1144 extraTyVarInfo :: ReportErrCtxt -> TcTyVar -> TcType -> SDoc
1145 -- Add on extra info about skolem constants
1146 -- NB: The types themselves are already tidied
1147 extraTyVarInfo ctxt tv1 ty2
1148 = tv_extra tv1 $$ ty_extra ty2
1149 where
1150 implics = cec_encl ctxt
1151 ty_extra ty = case tcGetTyVar_maybe ty of
1152 Just tv -> tv_extra tv
1153 Nothing -> empty
1154
1155 tv_extra tv | isTcTyVar tv, isSkolemTyVar tv
1156 , let pp_tv = quotes (ppr tv)
1157 = case tcTyVarDetails tv of
1158 SkolemTv {} -> pp_tv <+> pprSkol (getSkolemInfo implics tv) (getSrcLoc tv)
1159 FlatSkol {} -> pp_tv <+> ptext (sLit "is a flattening type variable")
1160 RuntimeUnk {} -> pp_tv <+> ptext (sLit "is an interactive-debugger skolem")
1161 MetaTv {} -> empty
1162
1163 | otherwise -- Normal case
1164 = empty
1165
1166 suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> SDoc
1167 -- See Note [Suggest adding a type signature]
1168 suggestAddSig ctxt ty1 ty2
1169 | null inferred_bndrs
1170 = empty
1171 | [bndr] <- inferred_bndrs
1172 = ptext (sLit "Possible fix: add a type signature for") <+> quotes (ppr bndr)
1173 | otherwise
1174 = ptext (sLit "Possible fix: add type signatures for some or all of") <+> (ppr inferred_bndrs)
1175 where
1176 inferred_bndrs = nub (get_inf ty1 ++ get_inf ty2)
1177 get_inf ty | Just tv <- tcGetTyVar_maybe ty
1178 , isTcTyVar tv, isSkolemTyVar tv
1179 , InferSkol prs <- getSkolemInfo (cec_encl ctxt) tv
1180 = map fst prs
1181 | otherwise
1182 = []
1183
1184 kindErrorMsg :: TcType -> TcType -> SDoc -- Types are already tidy
1185 kindErrorMsg ty1 ty2
1186 = vcat [ ptext (sLit "Kind incompatibility when matching types:")
1187 , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1
1188 , ppr ty2 <+> dcolon <+> ppr k2 ]) ]
1189 where
1190 k1 = typeKind ty1
1191 k2 = typeKind ty2
1192
1193 --------------------
1194 misMatchMsg :: Ct -> Maybe SwapFlag -> TcType -> TcType -> SDoc
1195 -- Types are already tidy
1196 -- If oriented then ty1 is actual, ty2 is expected
1197 misMatchMsg ct oriented ty1 ty2
1198 | Just NotSwapped <- oriented
1199 = misMatchMsg ct (Just IsSwapped) ty2 ty1
1200
1201 | otherwise -- So now we have Nothing or (Just IsSwapped)
1202 -- For some reason we treat Nothign like IsSwapped
1203 = addArising orig $
1204 sep [ text herald1 <+> quotes (ppr ty1)
1205 , nest padding $
1206 text herald2 <+> quotes (ppr ty2)
1207 , sameOccExtra ty2 ty1 ]
1208 where
1209 herald1 = conc [ "Couldn't match"
1210 , if is_repr then "representation of" else ""
1211 , if is_oriented then "expected" else ""
1212 , what ]
1213 herald2 = conc [ "with"
1214 , if is_repr then "that of" else ""
1215 , if is_oriented then ("actual " ++ what) else "" ]
1216 padding = length herald1 - length herald2
1217
1218 is_repr = case ctEqRel ct of { ReprEq -> True; NomEq -> False }
1219 is_oriented = isJust oriented
1220
1221 orig = ctOrigin ct
1222 what | isKind ty1 = "kind"
1223 | otherwise = "type"
1224
1225 conc :: [String] -> String
1226 conc = foldr1 add_space
1227
1228 add_space :: String -> String -> String
1229 add_space s1 s2 | null s1 = s2
1230 | null s2 = s1
1231 | otherwise = s1 ++ (' ' : s2)
1232
1233 mkExpectedActualMsg :: Type -> Type -> CtOrigin -> Bool
1234 -> (Maybe SwapFlag, SDoc)
1235 -- NotSwapped means (actual, expected), IsSwapped is the reverse
1236 mkExpectedActualMsg ty1 ty2
1237 (TypeEqOrigin { uo_actual = act, uo_expected = exp }) printExpanded
1238 | act `pickyEqType` ty1, exp `pickyEqType` ty2 = (Just NotSwapped, empty)
1239 | exp `pickyEqType` ty1, act `pickyEqType` ty2 = (Just IsSwapped, empty)
1240 | otherwise = (Nothing, msg)
1241 where
1242 msg = vcat
1243 [ text "Expected type:" <+> ppr exp
1244 , text " Actual type:" <+> ppr act
1245 , if printExpanded then expandedTys else empty
1246 ]
1247
1248 expandedTys =
1249 ppUnless (expTy1 `pickyEqType` exp && expTy2 `pickyEqType` act) $ vcat
1250 [ text "Type synonyms expanded:"
1251 , text "Expected type:" <+> ppr expTy1
1252 , text " Actual type:" <+> ppr expTy2
1253 ]
1254
1255 (expTy1, expTy2) = expandSynonymsToMatch exp act
1256
1257 mkExpectedActualMsg _ _ _ _ = panic "mkExpectedAcutalMsg"
1258
1259 pickyEqType :: TcType -> TcType -> Bool
1260 -- ^ Check when two types _look_ the same, _including_ synonyms.
1261 -- So (pickyEqType String [Char]) returns False
1262 pickyEqType ty1 ty2
1263 = go init_env ty1 ty2
1264 where
1265 init_env =
1266 mkRnEnv2 (mkInScopeSet (tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2))
1267 go env (TyVarTy tv1) (TyVarTy tv2) =
1268 rnOccL env tv1 == rnOccR env tv2
1269 go _ (LitTy lit1) (LitTy lit2) =
1270 lit1 == lit2
1271 go env (ForAllTy tv1 t1) (ForAllTy tv2 t2) =
1272 go env (tyVarKind tv1) (tyVarKind tv2) && go (rnBndr2 env tv1 tv2) t1 t2
1273 go env (AppTy s1 t1) (AppTy s2 t2) =
1274 go env s1 s2 && go env t1 t2
1275 go env (FunTy s1 t1) (FunTy s2 t2) =
1276 go env s1 s2 && go env t1 t2
1277 go env (TyConApp tc1 ts1) (TyConApp tc2 ts2) =
1278 (tc1 == tc2) && gos env ts1 ts2
1279 go _ _ _ =
1280 False
1281
1282 gos _ [] [] = True
1283 gos env (t1:ts1) (t2:ts2) = go env t1 t2 && gos env ts1 ts2
1284 gos _ _ _ = False
1285
1286 {-
1287 Note [Expanding type synonyms to make types similar]
1288 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1289
1290 In type error messages, if -fprint-expanded-types is used, we want to expand
1291 type synonyms to make expected and found types as similar as possible, but we
1292 shouldn't expand types too much to make type messages even more verbose and
1293 harder to understand. The whole point here is to make the difference in expected
1294 and found types clearer.
1295
1296 `expandSynonymsToMatch` does this, it takes two types, and expands type synonyms
1297 only as much as necessary. It should work like this:
1298
1299 Given two types t1 and t2:
1300
1301 * If they're already same, it shouldn't expand any type synonyms and
1302 just return.
1303
1304 * If they're in form `C1 t1_1 .. t1_n` and `C2 t2_1 .. t2_m` (C1 and C2 are
1305 type constructors), it should expand C1 and C2 if they're different type
1306 synonyms. Then it should continue doing same thing on expanded types. If C1
1307 and C2 are same, then we should apply same procedure to arguments of C1
1308 and argument of C2 to make them as similar as possible.
1309
1310 Most important thing here is to keep number of synonym expansions at
1311 minimum. For example, if t1 is `T (T3, T5, Int)` and t2 is
1312 `T (T5, T3, Bool)` where T5 = T4, T4 = T3, ..., T1 = X, we should return
1313 `T (T3, T3, Int)` and `T (T3, T3, Bool)`.
1314
1315 In the implementation, we just search in all possible solutions for a solution
1316 that does minimum amount of expansions. This leads to a complex algorithm: If
1317 we have two synonyms like X_m = X_{m-1} = .. X and Y_n = Y_{n-1} = .. Y, where
1318 X and Y are rigid types, we expand m * n times. But in practice it's not a
1319 problem because deeply nested synonyms with no intervening rigid type
1320 constructors are vanishingly rare.
1321
1322 -}
1323
1324 -- | Expand type synonyms in given types only enough to make them as equal as
1325 -- possible. Returned types are the same in terms of used type synonyms.
1326 --
1327 -- To expand all synonyms, see 'Type.expandTypeSynonyms'.
1328 expandSynonymsToMatch :: Type -> Type -> (Type, Type)
1329 expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret)
1330 where
1331 (_, ty1_ret, ty2_ret) = go 0 ty1 ty2
1332
1333 -- | Returns (number of synonym expansions done to make types similar,
1334 -- type synonym expanded version of first type,
1335 -- type synonym expanded version of second type)
1336 --
1337 -- Int argument is number of synonym expansions done so far.
1338 go :: Int -> Type -> Type -> (Int, Type, Type)
1339 go exps t1 t2
1340 | t1 `pickyEqType` t2 =
1341 -- Types are same, nothing to do
1342 (exps, t1, t2)
1343
1344 go exps t1@(TyConApp tc1 tys1) t2@(TyConApp tc2 tys2)
1345 | tc1 == tc2 =
1346 -- Type constructors are same. They may be synonyms, but we don't
1347 -- expand further.
1348 let (exps', tys1', tys2') = unzip3 $ zipWith (go 0) tys1 tys2
1349 in (exps + sum exps', TyConApp tc1 tys1', TyConApp tc2 tys2')
1350 | otherwise =
1351 -- Try to expand type constructors
1352 case (tcView t1, tcView t2) of
1353 -- When only one of the constructors is a synonym, we just
1354 -- expand it and continue search
1355 (Just t1', Nothing) ->
1356 go (exps + 1) t1' t2
1357 (Nothing, Just t2') ->
1358 go (exps + 1) t1 t2'
1359 (Just t1', Just t2') ->
1360 -- Both constructors are synonyms, but they may be synonyms of
1361 -- each other. We just search for minimally expanded solution.
1362 -- See Note [Expanding type synonyms to make types similar].
1363 let sol1@(exp1, _, _) = go (exps + 1) t1' t2
1364 sol2@(exp2, _, _) = go (exps + 1) t1 t2'
1365 in if exp1 < exp2 then sol1 else sol2
1366 (Nothing, Nothing) ->
1367 -- None of the constructors are synonyms, nothing to do
1368 (exps, t1, t2)
1369
1370 go exps t1@TyConApp{} t2
1371 | Just t1' <- tcView t1 = go (exps + 1) t1' t2
1372 | otherwise = (exps, t1, t2)
1373
1374 go exps t1 t2@TyConApp{}
1375 | Just t2' <- tcView t2 = go (exps + 1) t1 t2'
1376 | otherwise = (exps, t1, t2)
1377
1378 go exps (AppTy t1_1 t1_2) (AppTy t2_1 t2_2) =
1379 let (exps1, t1_1', t2_1') = go 0 t1_1 t2_1
1380 (exps2, t1_2', t2_2') = go 0 t1_2 t2_2
1381 in (exps + exps1 + exps2, mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2')
1382
1383 go exps (FunTy t1_1 t1_2) (FunTy t2_1 t2_2) =
1384 let (exps1, t1_1', t2_1') = go 0 t1_1 t2_1
1385 (exps2, t1_2', t2_2') = go 0 t1_2 t2_2
1386 in (exps + exps1 + exps2, FunTy t1_1' t1_2', FunTy t2_1' t2_2')
1387
1388 go exps (ForAllTy tv1 t1) (ForAllTy tv2 t2) =
1389 -- NOTE: We may have a bug here, but we just can't reproduce it easily.
1390 -- See D1016 comments for details and our attempts at producing a test
1391 -- case.
1392 let (exps1, t1', t2') = go exps t1 t2
1393 in (exps1, ForAllTy tv1 t1', ForAllTy tv2 t2')
1394
1395 go exps t1 t2 = (exps, t1, t2)
1396
1397 sameOccExtra :: TcType -> TcType -> SDoc
1398 -- See Note [Disambiguating (X ~ X) errors]
1399 sameOccExtra ty1 ty2
1400 | Just (tc1, _) <- tcSplitTyConApp_maybe ty1
1401 , Just (tc2, _) <- tcSplitTyConApp_maybe ty2
1402 , let n1 = tyConName tc1
1403 n2 = tyConName tc2
1404 same_occ = nameOccName n1 == nameOccName n2
1405 same_pkg = moduleUnitId (nameModule n1) == moduleUnitId (nameModule n2)
1406 , n1 /= n2 -- Different Names
1407 , same_occ -- but same OccName
1408 = ptext (sLit "NB:") <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2)
1409 | otherwise
1410 = empty
1411 where
1412 ppr_from same_pkg nm
1413 | isGoodSrcSpan loc
1414 = hang (quotes (ppr nm) <+> ptext (sLit "is defined at"))
1415 2 (ppr loc)
1416 | otherwise -- Imported things have an UnhelpfulSrcSpan
1417 = hang (quotes (ppr nm))
1418 2 (sep [ ptext (sLit "is defined in") <+> quotes (ppr (moduleName mod))
1419 , ppUnless (same_pkg || pkg == mainUnitId) $
1420 nest 4 $ ptext (sLit "in package") <+> quotes (ppr pkg) ])
1421 where
1422 pkg = moduleUnitId mod
1423 mod = nameModule nm
1424 loc = nameSrcSpan nm
1425
1426 {-
1427 Note [Suggest adding a type signature]
1428 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1429 The OutsideIn algorithm rejects GADT programs that don't have a principal
1430 type, and indeed some that do. Example:
1431 data T a where
1432 MkT :: Int -> T Int
1433
1434 f (MkT n) = n
1435
1436 Does this have type f :: T a -> a, or f :: T a -> Int?
1437 The error that shows up tends to be an attempt to unify an
1438 untouchable type variable. So suggestAddSig sees if the offending
1439 type variable is bound by an *inferred* signature, and suggests
1440 adding a declared signature instead.
1441
1442 This initially came up in Trac #8968, concerning pattern synonyms.
1443
1444 Note [Disambiguating (X ~ X) errors]
1445 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1446 See Trac #8278
1447
1448 Note [Reporting occurs-check errors]
1449 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1450 Given (a ~ [a]), if 'a' is a rigid type variable bound by a user-supplied
1451 type signature, then the best thing is to report that we can't unify
1452 a with [a], because a is a skolem variable. That avoids the confusing
1453 "occur-check" error message.
1454
1455 But nowadays when inferring the type of a function with no type signature,
1456 even if there are errors inside, we still generalise its signature and
1457 carry on. For example
1458 f x = x:x
1459 Here we will infer somethiing like
1460 f :: forall a. a -> [a]
1461 with a suspended error of (a ~ [a]). So 'a' is now a skolem, but not
1462 one bound by the programmer! Here we really should report an occurs check.
1463
1464 So isUserSkolem distinguishes the two.
1465
1466 Note [Non-injective type functions]
1467 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1468 It's very confusing to get a message like
1469 Couldn't match expected type `Depend s'
1470 against inferred type `Depend s1'
1471 so mkTyFunInfoMsg adds:
1472 NB: `Depend' is type function, and hence may not be injective
1473
1474 Warn of loopy local equalities that were dropped.
1475
1476
1477 ************************************************************************
1478 * *
1479 Type-class errors
1480 * *
1481 ************************************************************************
1482 -}
1483
1484 mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
1485 mkDictErr ctxt cts
1486 = ASSERT( not (null cts) )
1487 do { inst_envs <- tcGetInstEnvs
1488 ; let (ct1:_) = cts -- ct1 just for its location
1489 min_cts = elim_superclasses cts
1490 ; lookups <- mapM (lookup_cls_inst inst_envs) min_cts
1491 ; let (no_inst_cts, overlap_cts) = partition is_no_inst lookups
1492
1493 -- Report definite no-instance errors,
1494 -- or (iff there are none) overlap errors
1495 -- But we report only one of them (hence 'head') because they all
1496 -- have the same source-location origin, to try avoid a cascade
1497 -- of error from one location
1498 ; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts))
1499 ; mkErrorMsgFromCt ctxt ct1 err }
1500 where
1501 no_givens = null (getUserGivens ctxt)
1502
1503 is_no_inst (ct, (matches, unifiers, _))
1504 = no_givens
1505 && null matches
1506 && (null unifiers || all (not . isAmbiguousTyVar) (varSetElems (tyVarsOfCt ct)))
1507
1508 lookup_cls_inst inst_envs ct
1509 = do { tys_flat <- mapM quickFlattenTy tys
1510 -- Note [Flattening in error message generation]
1511 ; return (ct, lookupInstEnv True inst_envs clas tys_flat) }
1512 where
1513 (clas, tys) = getClassPredTys (ctPred ct)
1514
1515
1516 -- When simplifying [W] Ord (Set a), we need
1517 -- [W] Eq a, [W] Ord a
1518 -- but we really only want to report the latter
1519 elim_superclasses cts
1520 = filter (\ct -> any (eqPred (ctPred ct)) min_preds) cts
1521 where
1522 min_preds = mkMinimalBySCs (map ctPred cts)
1523
1524 mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult)
1525 -> TcM (ReportErrCtxt, SDoc)
1526 -- Report an overlap error if this class constraint results
1527 -- from an overlap (returning Left clas), otherwise return (Right pred)
1528 mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped))
1529 | null matches -- No matches but perhaps several unifiers
1530 = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
1531 ; return (ctxt, cannot_resolve_msg ct binds_msg) }
1532
1533 | null unsafe_overlapped -- Some matches => overlap errors
1534 = return (ctxt, overlap_msg)
1535
1536 | otherwise
1537 = return (ctxt, safe_haskell_msg)
1538 where
1539 orig = ctOrigin ct
1540 pred = ctPred ct
1541 (clas, tys) = getClassPredTys pred
1542 ispecs = [ispec | (ispec, _) <- matches]
1543 unsafe_ispecs = [ispec | (ispec, _) <- unsafe_overlapped]
1544 givens = getUserGivens ctxt
1545 all_tyvars = all isTyVarTy tys
1546
1547
1548 cannot_resolve_msg :: Ct -> SDoc -> SDoc
1549 cannot_resolve_msg ct binds_msg
1550 = vcat [ no_inst_msg
1551 , nest 2 extra_note
1552 , vcat (pp_givens givens)
1553 , ppWhen (has_ambig_tvs && not (null unifiers && null givens))
1554 (vcat [ ppUnless lead_with_ambig ambig_msg, binds_msg, potential_msg ])
1555 , show_fixes (add_to_ctxt_fixes has_ambig_tvs ++ drv_fixes) ]
1556 where
1557 orig = ctOrigin ct
1558 -- See Note [Highlighting ambiguous type variables]
1559 lead_with_ambig = has_ambig_tvs && not (any isRuntimeUnkSkol ambig_tvs)
1560 && not (null unifiers) && null givens
1561
1562 (has_ambig_tvs, ambig_msg) = mkAmbigMsg lead_with_ambig ct
1563 ambig_tvs = getAmbigTkvs ct
1564
1565 no_inst_msg
1566 | lead_with_ambig
1567 = ambig_msg <+> pprArising orig
1568 $$ text "prevents the constraint" <+> quotes (pprParendType pred)
1569 <+> text "from being solved."
1570
1571 | null givens
1572 = addArising orig $ text "No instance for"
1573 <+> pprParendType pred
1574
1575 | otherwise
1576 = addArising orig $ text "Could not deduce"
1577 <+> pprParendType pred
1578
1579 potential_msg
1580 = ppWhen (not (null unifiers) && want_potential orig) $
1581 sdocWithDynFlags $ \dflags ->
1582 getPprStyle $ \sty ->
1583 pprPotentials dflags sty potential_hdr unifiers
1584
1585 potential_hdr
1586 = vcat [ ppWhen lead_with_ambig $
1587 text "Probable fix: use a type annotation to specify what"
1588 <+> pprQuotedList ambig_tvs <+> text "should be."
1589 , ptext (sLit "These potential instance") <> plural unifiers
1590 <+> text "exist:"]
1591
1592 -- Report "potential instances" only when the constraint arises
1593 -- directly from the user's use of an overloaded function
1594 want_potential (TypeEqOrigin {}) = False
1595 want_potential _ = True
1596
1597 add_to_ctxt_fixes has_ambig_tvs
1598 | not has_ambig_tvs && all_tyvars
1599 , (orig:origs) <- usefulContext ctxt pred
1600 = [sep [ ptext (sLit "add") <+> pprParendType pred
1601 <+> ptext (sLit "to the context of")
1602 , nest 2 $ ppr_skol orig $$
1603 vcat [ ptext (sLit "or") <+> ppr_skol orig
1604 | orig <- origs ] ] ]
1605 | otherwise = []
1606
1607 ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc)
1608 ppr_skol skol_info = ppr skol_info
1609
1610 extra_note | any isFunTy (filterOut isKind tys)
1611 = ptext (sLit "(maybe you haven't applied a function to enough arguments?)")
1612 | className clas == typeableClassName -- Avoid mysterious "No instance for (Typeable T)
1613 , [_,ty] <- tys -- Look for (Typeable (k->*) (T k))
1614 , Just (tc,_) <- tcSplitTyConApp_maybe ty
1615 , not (isTypeFamilyTyCon tc)
1616 = hang (ptext (sLit "GHC can't yet do polykinded"))
1617 2 (ptext (sLit "Typeable") <+> parens (ppr ty <+> dcolon <+> ppr (typeKind ty)))
1618 | otherwise
1619 = empty
1620
1621 drv_fixes = case orig of
1622 DerivOrigin -> [drv_fix]
1623 DerivOriginDC {} -> [drv_fix]
1624 DerivOriginCoerce {} -> [drv_fix]
1625 _ -> []
1626
1627 drv_fix = hang (ptext (sLit "use a standalone 'deriving instance' declaration,"))
1628 2 (ptext (sLit "so you can specify the instance context yourself"))
1629
1630 -- Normal overlap error
1631 overlap_msg
1632 = ASSERT( not (null matches) )
1633 vcat [ addArising orig (ptext (sLit "Overlapping instances for")
1634 <+> pprType (mkClassPred clas tys))
1635
1636 , ppUnless (null matching_givens) $
1637 sep [ptext (sLit "Matching givens (or their superclasses):")
1638 , nest 2 (vcat matching_givens)]
1639
1640 , sdocWithDynFlags $ \dflags ->
1641 getPprStyle $ \sty ->
1642 pprPotentials dflags sty (ptext (sLit "Matching instances:")) $
1643 ispecs ++ unifiers
1644
1645 , ppWhen (null matching_givens && isSingleton matches && null unifiers) $
1646 -- Intuitively, some given matched the wanted in their
1647 -- flattened or rewritten (from given equalities) form
1648 -- but the matcher can't figure that out because the
1649 -- constraints are non-flat and non-rewritten so we
1650 -- simply report back the whole given
1651 -- context. Accelerate Smart.hs showed this problem.
1652 sep [ ptext (sLit "There exists a (perhaps superclass) match:")
1653 , nest 2 (vcat (pp_givens givens))]
1654
1655 , ppWhen (isSingleton matches) $
1656 parens (vcat [ ptext (sLit "The choice depends on the instantiation of") <+>
1657 quotes (pprWithCommas ppr (varSetElems (tyVarsOfTypes tys)))
1658 , ppWhen (null (matching_givens)) $
1659 vcat [ ptext (sLit "To pick the first instance above, use IncoherentInstances")
1660 , ptext (sLit "when compiling the other instance declarations")]
1661 ])]
1662 where
1663 givens = getUserGivens ctxt
1664 matching_givens = mapMaybe matchable givens
1665
1666 matchable (evvars,skol_info,_,loc)
1667 = case ev_vars_matching of
1668 [] -> Nothing
1669 _ -> Just $ hang (pprTheta ev_vars_matching)
1670 2 (sep [ ptext (sLit "bound by") <+> ppr skol_info
1671 , ptext (sLit "at") <+> ppr loc])
1672 where ev_vars_matching = filter ev_var_matches (map evVarPred evvars)
1673 ev_var_matches ty = case getClassPredTys_maybe ty of
1674 Just (clas', tys')
1675 | clas' == clas
1676 , Just _ <- tcMatchTys (tyVarsOfTypes tys) tys tys'
1677 -> True
1678 | otherwise
1679 -> any ev_var_matches (immSuperClasses clas' tys')
1680 Nothing -> False
1681
1682 -- Overlap error because of Safe Haskell (first
1683 -- match should be the most specific match)
1684 safe_haskell_msg
1685 = ASSERT( length matches == 1 && not (null unsafe_ispecs) )
1686 vcat [ addArising orig (ptext (sLit "Unsafe overlapping instances for")
1687 <+> pprType (mkClassPred clas tys))
1688 , sep [ptext (sLit "The matching instance is:"),
1689 nest 2 (pprInstance $ head ispecs)]
1690 , vcat [ ptext $ sLit "It is compiled in a Safe module and as such can only"
1691 , ptext $ sLit "overlap instances from the same module, however it"
1692 , ptext $ sLit "overlaps the following instances from different modules:"
1693 , nest 2 (vcat [pprInstances $ unsafe_ispecs])
1694 ]
1695 ]
1696
1697 {- Note [Highlighting ambiguous type variables]
1698 -----------------------------------------------
1699 When we encounter ambiguous type variables (i.e. type variables
1700 that remain metavariables after type inference), we need a few more
1701 conditions before we can reason that *ambiguity* prevents constraints
1702 from being solved:
1703 - We can't have any givens, as encountering a typeclass error
1704 with given constraints just means we couldn't deduce
1705 a solution satisfying those constraints and as such couldn't
1706 bind the type variable to a known type.
1707 - If we don't have any unifiers, we don't even have potential
1708 instances from which an ambiguity could arise.
1709 - Lastly, I don't want to mess with error reporting for
1710 unknown runtime types so we just fall back to the old message there.
1711 Once these conditions are satisfied, we can safely say that ambiguity prevents
1712 the constraint from being solved. -}
1713
1714
1715 usefulContext :: ReportErrCtxt -> TcPredType -> [SkolemInfo]
1716 usefulContext ctxt pred
1717 = go (cec_encl ctxt)
1718 where
1719 pred_tvs = tyVarsOfType pred
1720 go [] = []
1721 go (ic : ics)
1722 | implausible ic = rest
1723 | otherwise = ic_info ic : rest
1724 where
1725 -- Stop when the context binds a variable free in the predicate
1726 rest | any (`elemVarSet` pred_tvs) (ic_skols ic) = []
1727 | otherwise = go ics
1728
1729 implausible ic
1730 | null (ic_skols ic) = True
1731 | implausible_info (ic_info ic) = True
1732 | otherwise = False
1733
1734 implausible_info (SigSkol (InfSigCtxt {}) _) = True
1735 implausible_info _ = False
1736 -- Do not suggest adding constraints to an *inferred* type signature!
1737
1738 show_fixes :: [SDoc] -> SDoc
1739 show_fixes [] = empty
1740 show_fixes (f:fs) = sep [ ptext (sLit "Possible fix:")
1741 , nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
1742
1743 pprPotentials :: DynFlags -> PprStyle -> SDoc -> [ClsInst] -> SDoc
1744 -- See Note [Displaying potential instances]
1745 pprPotentials dflags sty herald insts
1746 | null insts
1747 = empty
1748
1749 | null show_these
1750 = hang herald
1751 2 (vcat [ not_in_scope_msg empty
1752 , flag_hint ])
1753
1754 | otherwise
1755 = hang herald
1756 2 (vcat [ pprInstances show_these
1757 , ppWhen (n_in_scope_hidden > 0) $
1758 ptext (sLit "...plus")
1759 <+> speakNOf n_in_scope_hidden (ptext (sLit "other"))
1760 , not_in_scope_msg (ptext (sLit "...plus"))
1761 , flag_hint ])
1762 where
1763 n_show = 3 :: Int
1764 show_potentials = gopt Opt_PrintPotentialInstances dflags
1765
1766 (in_scope, not_in_scope) = partition inst_in_scope insts
1767 sorted = sortBy fuzzyClsInstCmp in_scope
1768 show_these | show_potentials = sorted
1769 | otherwise = take n_show sorted
1770 n_in_scope_hidden = length sorted - length show_these
1771
1772 -- "in scope" means that all the type constructors
1773 -- are lexically in scope; these instances are likely
1774 -- to be more useful
1775 inst_in_scope :: ClsInst -> Bool
1776 inst_in_scope cls_inst = foldNameSet ((&&) . name_in_scope) True $
1777 orphNamesOfTypes (is_tys cls_inst)
1778
1779 name_in_scope name
1780 | isBuiltInSyntax name
1781 = True -- E.g. (->)
1782 | Just mod <- nameModule_maybe name
1783 = qual_in_scope (qualName sty mod (nameOccName name))
1784 | otherwise
1785 = True
1786
1787 qual_in_scope :: QualifyName -> Bool
1788 qual_in_scope NameUnqual = True
1789 qual_in_scope (NameQual {}) = True
1790 qual_in_scope _ = False
1791
1792 not_in_scope_msg herald
1793 | null not_in_scope
1794 = empty
1795 | otherwise
1796 = hang (herald <+> speakNOf (length not_in_scope)
1797 (ptext (sLit "instance involving out-of-scope types")))
1798 2 (ppWhen show_potentials (pprInstances not_in_scope))
1799
1800 flag_hint = ppUnless (show_potentials || length show_these == length insts) $
1801 ptext (sLit "(use -fprint-potential-instances to see them all)")
1802
1803 {- Note [Displaying potential instances]
1804 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1805 When showing a list of instances for
1806 - overlapping instances (show ones that match)
1807 - no such instance (show ones that could match)
1808 we want to give it a bit of structure. Here's the plan
1809
1810 * Say that an instance is "in scope" if all of the
1811 type constructors it mentions are lexically in scope.
1812 These are the ones most likely to be useful to the programmer.
1813
1814 * Show at most n_show in-scope instances,
1815 and summarise the rest ("plus 3 others")
1816
1817 * Summarise the not-in-scope instances ("plus 4 not in scope")
1818
1819 * Add the flag -fshow-potential-instances which replaces the
1820 summary with the full list
1821 -}
1822
1823 quickFlattenTy :: TcType -> TcM TcType
1824 -- See Note [Flattening in error message generation]
1825 quickFlattenTy ty | Just ty' <- tcView ty = quickFlattenTy ty'
1826 quickFlattenTy ty@(TyVarTy {}) = return ty
1827 quickFlattenTy ty@(ForAllTy {}) = return ty -- See
1828 quickFlattenTy ty@(LitTy {}) = return ty
1829 -- Don't flatten because of the danger or removing a bound variable
1830 quickFlattenTy (AppTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
1831 ; fy2 <- quickFlattenTy ty2
1832 ; return (AppTy fy1 fy2) }
1833 quickFlattenTy (FunTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
1834 ; fy2 <- quickFlattenTy ty2
1835 ; return (FunTy fy1 fy2) }
1836 quickFlattenTy (TyConApp tc tys)
1837 | not (isTypeFamilyTyCon tc)
1838 = do { fys <- mapM quickFlattenTy tys
1839 ; return (TyConApp tc fys) }
1840 | otherwise
1841 = do { let (funtys,resttys) = splitAt (tyConArity tc) tys
1842 -- Ignore the arguments of the type family funtys
1843 ; v <- newMetaTyVar TauTv (typeKind (TyConApp tc funtys))
1844 ; flat_resttys <- mapM quickFlattenTy resttys
1845 ; return (foldl AppTy (mkTyVarTy v) flat_resttys) }
1846
1847 {- Note [Flattening in error message generation]
1848 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1849 Consider (C (Maybe (F x))), where F is a type function, and we have
1850 instances
1851 C (Maybe Int) and C (Maybe a)
1852 Since (F x) might turn into Int, this is an overlap situation, and
1853 indeed (because of flattening) the main solver will have refrained
1854 from solving. But by the time we get to error message generation, we've
1855 un-flattened the constraint. So we must *re*-flatten it before looking
1856 up in the instance environment, lest we only report one matching
1857 instance when in fact there are two.
1858
1859 Re-flattening is pretty easy, because we don't need to keep track of
1860 evidence. We don't re-use the code in TcCanonical because that's in
1861 the TcS monad, and we are in TcM here.
1862
1863 Note [Quick-flatten polytypes]
1864 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1865 If we see C (Ix a => blah) or C (forall a. blah) we simply refrain from
1866 flattening any further. After all, there can be no instance declarations
1867 that match such things. And flattening under a for-all is problematic
1868 anyway; consider C (forall a. F a)
1869
1870 Note [Suggest -fprint-explicit-kinds]
1871 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1872 It can be terribly confusing to get an error message like (Trac #9171)
1873 Couldn't match expected type ‘GetParam Base (GetParam Base Int)’
1874 with actual type ‘GetParam Base (GetParam Base Int)’
1875 The reason may be that the kinds don't match up. Typically you'll get
1876 more useful information, but not when it's as a result of ambiguity.
1877 This test suggests -fprint-explicit-kinds when all the ambiguous type
1878 variables are kind variables.
1879 -}
1880
1881 mkAmbigMsg :: Bool -- True when message has to be at beginning of sentence
1882 -> Ct -> (Bool, SDoc)
1883 mkAmbigMsg prepend_msg ct
1884 | null ambig_tkvs = (False, empty)
1885 | otherwise = (True, msg)
1886 where
1887 ambig_tkvs = getAmbigTkvs ct
1888 (ambig_kvs, ambig_tvs) = partition isKindVar ambig_tkvs
1889
1890 msg | any isRuntimeUnkSkol ambig_tkvs -- See Note [Runtime skolems]
1891 = vcat [ ptext (sLit "Cannot resolve unknown runtime type")
1892 <> plural ambig_tvs <+> pprQuotedList ambig_tvs
1893 , ptext (sLit "Use :print or :force to determine these types")]
1894
1895 | not (null ambig_tvs)
1896 = pp_ambig (ptext (sLit "type")) ambig_tvs
1897
1898 | otherwise -- All ambiguous kind variabes; suggest -fprint-explicit-kinds
1899 = vcat [ pp_ambig (ptext (sLit "kind")) ambig_kvs
1900 , sdocWithDynFlags suggest_explicit_kinds ]
1901
1902 pp_ambig what tkvs
1903 | prepend_msg -- "Ambiguous type variable 't0'"
1904 = ptext (sLit "Ambiguous") <+> what <+> ptext (sLit "variable")
1905 <> plural tkvs <+> pprQuotedList tkvs
1906
1907 | otherwise -- "The type variable 't0' is ambiguous"
1908 = ptext (sLit "The") <+> what <+> ptext (sLit "variable") <> plural tkvs
1909 <+> pprQuotedList tkvs <+> is_or_are tkvs <+> ptext (sLit "ambiguous")
1910
1911 is_or_are [_] = text "is"
1912 is_or_are _ = text "are"
1913
1914 suggest_explicit_kinds dflags -- See Note [Suggest -fprint-explicit-kinds]
1915 | gopt Opt_PrintExplicitKinds dflags = empty
1916 | otherwise = ptext (sLit "Use -fprint-explicit-kinds to see the kind arguments")
1917
1918 getAmbigTkvs :: Ct -> [Var]
1919 getAmbigTkvs ct
1920 = varSetElems ambig_tkv_set
1921 where
1922 ambig_tkv_set = filterVarSet isAmbiguousTyVar (tyVarsOfCt ct)
1923
1924
1925 pprSkol :: SkolemInfo -> SrcLoc -> SDoc
1926 pprSkol UnkSkol _
1927 = ptext (sLit "is an unknown type variable")
1928 pprSkol skol_info tv_loc
1929 = sep [ ptext (sLit "is a rigid type variable bound by"),
1930 sep [ppr skol_info, ptext (sLit "at") <+> ppr tv_loc]]
1931
1932 getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo
1933 -- Get the skolem info for a type variable
1934 -- from the implication constraint that binds it
1935 getSkolemInfo [] tv
1936 = pprPanic "No skolem info:" (ppr tv)
1937
1938 getSkolemInfo (implic:implics) tv
1939 | tv `elem` ic_skols implic = ic_info implic
1940 | otherwise = getSkolemInfo implics tv
1941
1942 -----------------------
1943 -- relevantBindings looks at the value environment and finds values whose
1944 -- types mention any of the offending type variables. It has to be
1945 -- careful to zonk the Id's type first, so it has to be in the monad.
1946 -- We must be careful to pass it a zonked type variable, too.
1947 --
1948 -- We always remove closed top-level bindings, though,
1949 -- since they are never relevant (cf Trac #8233)
1950
1951 relevantBindings :: Bool -- True <=> filter by tyvar; False <=> no filtering
1952 -- See Trac #8191
1953 -> ReportErrCtxt -> Ct
1954 -> TcM (ReportErrCtxt, SDoc, Ct)
1955 -- Also returns the zonked and tidied CtOrigin of the constraint
1956 relevantBindings want_filtering ctxt ct
1957 = do { dflags <- getDynFlags
1958 ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc)
1959 ; let ct_tvs = tyVarsOfCt ct `unionVarSet` extra_tvs
1960
1961 -- For *kind* errors, report the relevant bindings of the
1962 -- enclosing *type* equality, because that's more useful for the programmer
1963 extra_tvs = case tidy_orig of
1964 KindEqOrigin t1 t2 _ -> tyVarsOfTypes [t1,t2]
1965 _ -> emptyVarSet
1966 ; traceTc "relevantBindings" $
1967 vcat [ ppr ct
1968 , pprCtOrigin (ctLocOrigin loc)
1969 , ppr ct_tvs
1970 , ppr [id | TcIdBndr id _ <- tcl_bndrs lcl_env] ]
1971
1972 ; (tidy_env', docs, discards)
1973 <- go env1 ct_tvs (maxRelevantBinds dflags)
1974 emptyVarSet [] False
1975 (tcl_bndrs lcl_env)
1976 -- tcl_bndrs has the innermost bindings first,
1977 -- which are probably the most relevant ones
1978
1979 ; let doc = ppUnless (null docs) $
1980 hang (ptext (sLit "Relevant bindings include"))
1981 2 (vcat docs $$ ppWhen discards discardMsg)
1982
1983 -- Put a zonked, tidied CtOrigin into the Ct
1984 loc' = setCtLocOrigin loc tidy_orig
1985 ct' = setCtLoc ct loc'
1986 ctxt' = ctxt { cec_tidy = tidy_env' }
1987
1988 ; return (ctxt', doc, ct') }
1989 where
1990 ev = ctEvidence ct
1991 loc = ctEvLoc ev
1992 lcl_env = ctLocEnv loc
1993
1994 run_out :: Maybe Int -> Bool
1995 run_out Nothing = False
1996 run_out (Just n) = n <= 0
1997
1998 dec_max :: Maybe Int -> Maybe Int
1999 dec_max = fmap (\n -> n - 1)
2000
2001 go :: TidyEnv -> TcTyVarSet -> Maybe Int -> TcTyVarSet -> [SDoc]
2002 -> Bool -- True <=> some filtered out due to lack of fuel
2003 -> [TcIdBinder]
2004 -> TcM (TidyEnv, [SDoc], Bool) -- The bool says if we filtered any out
2005 -- because of lack of fuel
2006 go tidy_env _ _ _ docs discards []
2007 = return (tidy_env, reverse docs, discards)
2008 go tidy_env ct_tvs n_left tvs_seen docs discards (TcIdBndr id top_lvl : tc_bndrs)
2009 = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id)
2010 ; traceTc "relevantBindings 1" (ppr id <+> dcolon <+> ppr tidy_ty)
2011 ; let id_tvs = tyVarsOfType tidy_ty
2012 doc = sep [ pprPrefixOcc id <+> dcolon <+> ppr tidy_ty
2013 , nest 2 (parens (ptext (sLit "bound at")
2014 <+> ppr (getSrcLoc id)))]
2015 new_seen = tvs_seen `unionVarSet` id_tvs
2016
2017 ; if (want_filtering && not opt_PprStyle_Debug
2018 && id_tvs `disjointVarSet` ct_tvs)
2019 -- We want to filter out this binding anyway
2020 -- so discard it silently
2021 then go tidy_env ct_tvs n_left tvs_seen docs discards tc_bndrs
2022
2023 else if isTopLevel top_lvl && not (isNothing n_left)
2024 -- It's a top-level binding and we have not specified
2025 -- -fno-max-relevant-bindings, so discard it silently
2026 then go tidy_env ct_tvs n_left tvs_seen docs discards tc_bndrs
2027
2028 else if run_out n_left && id_tvs `subVarSet` tvs_seen
2029 -- We've run out of n_left fuel and this binding only
2030 -- mentions aleady-seen type variables, so discard it
2031 then go tidy_env ct_tvs n_left tvs_seen docs True tc_bndrs
2032
2033 -- Keep this binding, decrement fuel
2034 else go tidy_env' ct_tvs (dec_max n_left) new_seen (doc:docs) discards tc_bndrs }
2035
2036 discardMsg :: SDoc
2037 discardMsg = ptext (sLit "(Some bindings suppressed; use -fmax-relevant-binds=N or -fno-max-relevant-binds)")
2038
2039 -----------------------
2040 warnDefaulting :: [Ct] -> Type -> TcM ()
2041 warnDefaulting wanteds default_ty
2042 = do { warn_default <- woptM Opt_WarnTypeDefaults
2043 ; env0 <- tcInitTidyEnv
2044 ; let tidy_env = tidyFreeTyVars env0 $
2045 foldr (unionVarSet . tyVarsOfCt) emptyVarSet wanteds
2046 tidy_wanteds = map (tidyCt tidy_env) wanteds
2047 (loc, ppr_wanteds) = pprWithArising tidy_wanteds
2048 warn_msg = hang (ptext (sLit "Defaulting the following constraint(s) to type")
2049 <+> quotes (ppr default_ty))
2050 2 ppr_wanteds
2051 ; setCtLocM loc $ warnTc warn_default warn_msg }
2052
2053 {-
2054 Note [Runtime skolems]
2055 ~~~~~~~~~~~~~~~~~~~~~~
2056 We want to give a reasonably helpful error message for ambiguity
2057 arising from *runtime* skolems in the debugger. These
2058 are created by in RtClosureInspect.zonkRTTIType.
2059
2060 ************************************************************************
2061 * *
2062 Error from the canonicaliser
2063 These ones are called *during* constraint simplification
2064 * *
2065 ************************************************************************
2066 -}
2067
2068 solverDepthErrorTcS :: CtLoc -> TcType -> TcM a
2069 solverDepthErrorTcS loc ty
2070 = setCtLocM loc $
2071 do { ty <- zonkTcType ty
2072 ; env0 <- tcInitTidyEnv
2073 ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfType ty)
2074 tidy_ty = tidyType tidy_env ty
2075 msg
2076 = vcat [ text "Reduction stack overflow; size =" <+> ppr depth
2077 , hang (text "When simplifying the following type:")
2078 2 (ppr tidy_ty)
2079 , note ]
2080 ; failWithTcM (tidy_env, msg) }
2081 where
2082 depth = ctLocDepth loc
2083 note = vcat
2084 [ text "Use -freduction-depth=0 to disable this check"
2085 , text "(any upper bound you could choose might fail unpredictably with"
2086 , text " minor updates to GHC, so disabling the check is recommended if"
2087 , text " you're sure that type checking should terminate)" ]