Implement support for user-defined type errors.
[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 = do { err <- mk_err ctxt cts
468 ; maybeReportError ctxt err
469 ; mapM_ (maybeAddDeferredBinding ctxt err) cts }
470 -- Add deferred bindings for all
471 -- But see Note [Always warn with -fdefer-type-errors]
472
473 maybeReportHoleError :: ReportErrCtxt -> Ct -> ErrMsg -> TcM ()
474 maybeReportHoleError ctxt ct err
475 -- When -XPartialTypeSignatures is on, warnings (instead of errors) are
476 -- generated for holes in partial type signatures. Unless
477 -- -fwarn_partial_type_signatures is not on, in which case the messages are
478 -- discarded.
479 | isTypeHoleCt ct
480 = -- For partial type signatures, generate warnings only, and do that
481 -- only if -fwarn_partial_type_signatures is on
482 case cec_type_holes ctxt of
483 HoleError -> reportError err
484 HoleWarn -> reportWarning err
485 HoleDefer -> return ()
486
487 -- Otherwise this is a typed hole in an expression
488 | otherwise
489 = -- If deferring, report a warning only if -fwarn-typed-holds is on
490 case cec_expr_holes ctxt of
491 HoleError -> reportError err
492 HoleWarn -> reportWarning err
493 HoleDefer -> return ()
494
495 maybeReportError :: ReportErrCtxt -> ErrMsg -> TcM ()
496 -- Report the error and/or make a deferred binding for it
497 maybeReportError ctxt err
498 | cec_errors_as_warns ctxt
499 = reportWarning err
500 | otherwise
501 = case cec_defer_type_errors ctxt of
502 TypeDefer -> return ()
503 TypeWarn -> reportWarning err
504 -- handle case when suppress is on like in the original code
505 TypeError -> if cec_suppress ctxt then return () else reportError err
506
507 addDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
508 -- See Note [Deferring coercion errors to runtime]
509 addDeferredBinding ctxt err ct
510 | CtWanted { ctev_pred = pred, ctev_evar = ev_id } <- ctEvidence ct
511 -- Only add deferred bindings for Wanted constraints
512 , Just ev_binds_var <- cec_binds ctxt -- We have somewhere to put the bindings
513 = do { dflags <- getDynFlags
514 ; let err_msg = pprLocErrMsg err
515 err_fs = mkFastString $ showSDoc dflags $
516 err_msg $$ text "(deferred type error)"
517
518 -- Create the binding
519 ; addTcEvBind ev_binds_var (mkWantedEvBind ev_id (EvDelayedError pred err_fs)) }
520
521 | otherwise -- Do not set any evidence for Given/Derived
522 = return ()
523
524 maybeAddDeferredHoleBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
525 maybeAddDeferredHoleBinding ctxt err ct
526 | isExprHoleCt ct
527 , case cec_expr_holes ctxt of
528 HoleDefer -> True
529 HoleWarn -> True
530 HoleError -> False
531 = addDeferredBinding ctxt err ct -- Only add bindings for holes in expressions
532 | otherwise -- not for holes in partial type signatures
533 = return ()
534
535 maybeAddDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
536 maybeAddDeferredBinding ctxt err ct =
537 case cec_defer_type_errors ctxt of
538 TypeDefer -> deferred
539 TypeWarn -> deferred
540 TypeError -> return ()
541 where
542 deferred = addDeferredBinding ctxt err ct
543
544 tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct])
545 -- Use the first reporter in the list whose predicate says True
546 tryReporters ctxt reporters cts
547 = do { traceTc "tryReporters {" (ppr cts)
548 ; (ctxt', cts') <- go ctxt reporters cts
549 ; traceTc "tryReporters }" (ppr cts')
550 ; return (ctxt', cts') }
551 where
552 go ctxt [] cts
553 = return (ctxt, cts)
554
555 go ctxt (r : rs) cts
556 = do { (ctxt', cts') <- tryReporter ctxt r cts
557 ; go ctxt' rs cts' }
558 -- Carry on with the rest, because we must make
559 -- deferred bindings for them if we have -fdefer-type-errors
560 -- But suppress their error messages
561
562 tryReporter :: ReportErrCtxt -> ReporterSpec -> [Ct] -> TcM (ReportErrCtxt, [Ct])
563 tryReporter ctxt (str, keep_me, suppress_after, reporter) cts
564 | null yeses = return (ctxt, cts)
565 | otherwise = do { traceTc "tryReporter:" (text str <+> ppr yeses)
566 ; reporter ctxt yeses
567 ; let ctxt' = ctxt { cec_suppress = suppress_after || cec_suppress ctxt }
568 ; return (ctxt', nos) }
569 where
570 (yeses, nos) = partition (\ct -> keep_me ct (classifyPredType (ctPred ct))) cts
571
572
573 pprArising :: CtOrigin -> SDoc
574 -- Used for the main, top-level error message
575 -- We've done special processing for TypeEq, KindEq, Given
576 pprArising (TypeEqOrigin {}) = empty
577 pprArising (KindEqOrigin {}) = empty
578 pprArising (GivenOrigin {}) = empty
579 pprArising orig = pprCtOrigin orig
580
581 -- Add the "arising from..." part to a message about bunch of dicts
582 addArising :: CtOrigin -> SDoc -> SDoc
583 addArising orig msg = hang msg 2 (pprArising orig)
584
585 pprWithArising :: [Ct] -> (CtLoc, SDoc)
586 -- Print something like
587 -- (Eq a) arising from a use of x at y
588 -- (Show a) arising from a use of p at q
589 -- Also return a location for the error message
590 -- Works for Wanted/Derived only
591 pprWithArising []
592 = panic "pprWithArising"
593 pprWithArising (ct:cts)
594 | null cts
595 = (loc, addArising (ctLocOrigin loc)
596 (pprTheta [ctPred ct]))
597 | otherwise
598 = (loc, vcat (map ppr_one (ct:cts)))
599 where
600 loc = ctLoc ct
601 ppr_one ct' = hang (parens (pprType (ctPred ct')))
602 2 (pprCtLoc (ctLoc ct'))
603
604 mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> SDoc -> TcM ErrMsg
605 mkErrorMsgFromCt ctxt ct msg
606 = mkErrorMsg ctxt (ctLocEnv (ctLoc ct)) msg
607
608 mkErrorMsg :: ReportErrCtxt -> TcLclEnv -> SDoc -> TcM ErrMsg
609 mkErrorMsg ctxt tcl_env msg
610 = do { err_info <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)
611 ; mkLongErrAt (RealSrcSpan (tcl_loc tcl_env)) msg err_info }
612
613 type UserGiven = ([EvVar], SkolemInfo, Bool, RealSrcSpan)
614
615 getUserGivens :: ReportErrCtxt -> [UserGiven]
616 -- One item for each enclosing implication
617 getUserGivens (CEC {cec_encl = ctxt})
618 = reverse $
619 [ (givens, info, no_eqs, tcl_loc env)
620 | Implic { ic_given = givens, ic_env = env
621 , ic_no_eqs = no_eqs, ic_info = info } <- ctxt
622 , not (null givens) ]
623
624 {-
625 Note [Always warn with -fdefer-type-errors]
626 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
627 When -fdefer-type-errors is on we warn about *all* type errors, even
628 if cec_suppress is on. This can lead to a lot more warnings than you
629 would get errors without -fdefer-type-errors, but if we suppress any of
630 them you might get a runtime error that wasn't warned about at compile
631 time.
632
633 This is an easy design choice to change; just flip the order of the
634 first two equations for maybeReportError
635
636 To be consistent, we should also report multiple warnings from a single
637 location in mkGroupReporter, when -fdefer-type-errors is on. But that
638 is perhaps a bit *over*-consistent! Again, an easy choice to change.
639
640 With #10283, you can now opt out of deferred type error warnings.
641
642
643 Note [Do not report derived but soluble errors]
644 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
645 The wc_simples include Derived constraints that have not been solved, but are
646 not insoluble (in that case they'd be in wc_insols). We do not want to report
647 these as errors:
648
649 * Superclass constraints. If we have an unsolved [W] Ord a, we'll also have
650 an unsolved [D] Eq a, and we do not want to report that; it's just noise.
651
652 * Functional dependencies. For givens, consider
653 class C a b | a -> b
654 data T a where
655 MkT :: C a d => [d] -> T a
656 f :: C a b => T a -> F Int
657 f (MkT xs) = length xs
658 Then we get a [D] b~d. But there *is* a legitimate call to
659 f, namely f (MkT [True]) :: T Bool, in which b=d. So we should
660 not reject the program.
661
662 For wanteds, something similar
663 data T a where
664 MkT :: C Int b => a -> b -> T a
665 g :: C Int c => c -> ()
666 f :: T a -> ()
667 f (MkT x y) = g x
668 Here we get [G] C Int b, [W] C Int a, hence [D] a~b.
669 But again f (MkT True True) is a legitimate call.
670
671 (We leave the Deriveds in wc_simple until reportErrors, so that we don't lose
672 derived superclasses between iterations of the solver.)
673
674 For functional dependencies, here is a real example,
675 stripped off from libraries/utf8-string/Codec/Binary/UTF8/Generic.hs
676
677 class C a b | a -> b
678 g :: C a b => a -> b -> ()
679 f :: C a b => a -> b -> ()
680 f xa xb =
681 let loop = g xa
682 in loop xb
683
684 We will first try to infer a type for loop, and we will succeed:
685 C a b' => b' -> ()
686 Subsequently, we will type check (loop xb) and all is good. But,
687 recall that we have to solve a final implication constraint:
688 C a b => (C a b' => .... cts from body of loop .... ))
689 And now we have a problem as we will generate an equality b ~ b' and fail to
690 solve it.
691
692
693 ************************************************************************
694 * *
695 Irreducible predicate errors
696 * *
697 ************************************************************************
698 -}
699
700 mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
701 mkIrredErr ctxt cts
702 = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1
703 ; let orig = ctOrigin ct1
704 msg = couldNotDeduce (getUserGivens ctxt) (map ctPred cts, orig)
705 ; mkErrorMsgFromCt ctxt ct1 (msg $$ binds_msg) }
706 where
707 (ct1:_) = cts
708
709 ----------------
710 mkHoleError :: ReportErrCtxt -> Ct -> TcM ErrMsg
711 mkHoleError ctxt ct@(CHoleCan { cc_occ = occ, cc_hole = hole_sort })
712 | isOutOfScopeCt ct -- Out of scope variables, like 'a', where 'a' isn't bound
713 -- Suggest possible in-scope variables in the message
714 = do { dflags <- getDynFlags
715 ; rdr_env <- getGlobalRdrEnv
716 ; mkLongErrAt (RealSrcSpan (tcl_loc lcl_env)) out_of_scope_msg
717 (unknownNameSuggestions dflags rdr_env
718 (tcl_rdr lcl_env) (mkRdrUnqual occ)) }
719
720 | otherwise -- Explicit holes, like "_" or "_f"
721 = do { (ctxt, binds_doc, ct) <- relevantBindings False ctxt ct
722 -- The 'False' means "don't filter the bindings"; see Trac #8191
723 ; mkErrorMsgFromCt ctxt ct (hole_msg $$ binds_doc) }
724
725 where
726 ct_loc = ctLoc ct
727 lcl_env = ctLocEnv ct_loc
728 hole_ty = ctEvPred (ctEvidence ct)
729 tyvars = varSetElems (tyVarsOfType hole_ty)
730 boring_type = isTyVarTy hole_ty
731
732 out_of_scope_msg -- Print v :: ty only if the type has structure
733 | boring_type = hang herald 2 (ppr occ)
734 | otherwise = hang herald 2 pp_with_type
735
736 pp_with_type = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType hole_ty)
737 herald | isDataOcc occ = ptext (sLit "Data constructor not in scope:")
738 | otherwise = ptext (sLit "Variable not in scope:")
739
740 hole_msg = case hole_sort of
741 ExprHole -> vcat [ hang (ptext (sLit "Found hole:"))
742 2 pp_with_type
743 , tyvars_msg, expr_hole_hint ]
744 TypeHole -> vcat [ hang (ptext (sLit "Found type wildcard") <+> quotes (ppr occ))
745 2 (ptext (sLit "standing for") <+> quotes (pprType hole_ty))
746 , tyvars_msg, type_hole_hint ]
747
748 tyvars_msg = ppUnless (null tyvars) $
749 ptext (sLit "Where:") <+> vcat (map loc_msg tyvars)
750
751 type_hole_hint
752 | HoleError <- cec_type_holes ctxt
753 = ptext (sLit "To use the inferred type, enable PartialTypeSignatures")
754 | otherwise
755 = empty
756
757 expr_hole_hint -- Give hint for, say, f x = _x
758 | lengthFS (occNameFS occ) > 1 -- Don't give this hint for plain "_"
759 = ptext (sLit "Or perhaps") <+> quotes (ppr occ)
760 <+> ptext (sLit "is mis-spelled, or not in scope")
761 | otherwise
762 = empty
763
764 loc_msg tv
765 = case tcTyVarDetails tv of
766 SkolemTv {} -> quotes (ppr tv) <+> skol_msg
767 MetaTv {} -> quotes (ppr tv) <+> ptext (sLit "is an ambiguous type variable")
768 det -> pprTcTyVarDetails det
769 where
770 skol_msg = pprSkol (getSkolemInfo (cec_encl ctxt) tv) (getSrcLoc tv)
771
772 mkHoleError _ ct = pprPanic "mkHoleError" (ppr ct)
773
774 ----------------
775 mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
776 mkIPErr ctxt cts
777 = do { (ctxt, bind_msg, ct1) <- relevantBindings True ctxt ct1
778 ; let orig = ctOrigin ct1
779 preds = map ctPred cts
780 givens = getUserGivens ctxt
781 msg | null givens
782 = addArising orig $
783 sep [ ptext (sLit "Unbound implicit parameter") <> plural cts
784 , nest 2 (pprTheta preds) ]
785 | otherwise
786 = couldNotDeduce givens (preds, orig)
787
788 ; mkErrorMsgFromCt ctxt ct1 (msg $$ bind_msg) }
789 where
790 (ct1:_) = cts
791
792 {-
793 ************************************************************************
794 * *
795 Equality errors
796 * *
797 ************************************************************************
798
799 Note [Inaccessible code]
800 ~~~~~~~~~~~~~~~~~~~~~~~~
801 Consider
802 data T a where
803 T1 :: T a
804 T2 :: T Bool
805
806 f :: (a ~ Int) => T a -> Int
807 f T1 = 3
808 f T2 = 4 -- Unreachable code
809
810 Here the second equation is unreachable. The original constraint
811 (a~Int) from the signature gets rewritten by the pattern-match to
812 (Bool~Int), so the danger is that we report the error as coming from
813 the *signature* (Trac #7293). So, for Given errors we replace the
814 env (and hence src-loc) on its CtLoc with that from the immediately
815 enclosing implication.
816 -}
817
818 mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
819 -- Don't have multiple equality errors from the same location
820 -- E.g. (Int,Bool) ~ (Bool,Int) one error will do!
821 mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct
822 mkEqErr _ [] = panic "mkEqErr"
823
824 mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg
825 -- Wanted constraints only!
826 mkEqErr1 ctxt ct
827 | isGivenCt ct
828 = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
829 ; let (given_loc, given_msg) = mk_given (ctLoc ct) (cec_encl ctxt)
830 ; dflags <- getDynFlags
831 ; mkEqErr_help dflags ctxt (given_msg $$ binds_msg)
832 (setCtLoc ct given_loc) -- Note [Inaccessible code]
833 Nothing ty1 ty2 }
834
835 | otherwise -- Wanted or derived
836 = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
837 ; rdr_env <- getGlobalRdrEnv
838 ; fam_envs <- tcGetFamInstEnvs
839 ; exp_syns <- goptM Opt_PrintExpandedSynonyms
840 ; let (is_oriented, wanted_msg) = mk_wanted_extra (ctOrigin ct) exp_syns
841 coercible_msg = case ctEqRel ct of
842 NomEq -> empty
843 ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2
844 ; dflags <- getDynFlags
845 ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctOrigin ct))
846 ; mkEqErr_help dflags ctxt (wanted_msg $$ coercible_msg $$ binds_msg)
847 ct is_oriented ty1 ty2 }
848 where
849 (ty1, ty2) = getEqPredTys (ctPred ct)
850
851 mk_given :: CtLoc -> [Implication] -> (CtLoc, SDoc)
852 -- For given constraints we overwrite the env (and hence src-loc)
853 -- with one from the implication. See Note [Inaccessible code]
854 mk_given loc [] = (loc, empty)
855 mk_given loc (implic : _) = (setCtLocEnv loc (ic_env implic)
856 , hang (ptext (sLit "Inaccessible code in"))
857 2 (ppr (ic_info implic)))
858
859 -- If the types in the error message are the same as the types
860 -- we are unifying, don't add the extra expected/actual message
861 mk_wanted_extra :: CtOrigin -> Bool -> (Maybe SwapFlag, SDoc)
862 mk_wanted_extra orig@(TypeEqOrigin {}) expandSyns
863 = mkExpectedActualMsg ty1 ty2 orig expandSyns
864
865 mk_wanted_extra (KindEqOrigin cty1 cty2 sub_o) expandSyns
866 = (Nothing, msg1 $$ msg2)
867 where
868 msg1 = hang (ptext (sLit "When matching types"))
869 2 (vcat [ ppr cty1 <+> dcolon <+> ppr (typeKind cty1)
870 , ppr cty2 <+> dcolon <+> ppr (typeKind cty2) ])
871 msg2 = case sub_o of
872 TypeEqOrigin {} ->
873 snd (mkExpectedActualMsg cty1 cty2 sub_o expandSyns)
874 _ ->
875 empty
876
877 mk_wanted_extra _ _ = (Nothing, empty)
878
879 -- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint
880 -- is left over.
881 mkCoercibleExplanation :: GlobalRdrEnv -> FamInstEnvs
882 -> TcType -> TcType -> SDoc
883 mkCoercibleExplanation rdr_env fam_envs ty1 ty2
884 | Just (tc, tys) <- tcSplitTyConApp_maybe ty1
885 , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys
886 , Just msg <- coercible_msg_for_tycon rep_tc
887 = msg
888 | Just (tc, tys) <- splitTyConApp_maybe ty2
889 , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys
890 , Just msg <- coercible_msg_for_tycon rep_tc
891 = msg
892 | Just (s1, _) <- tcSplitAppTy_maybe ty1
893 , Just (s2, _) <- tcSplitAppTy_maybe ty2
894 , s1 `eqType` s2
895 , has_unknown_roles s1
896 = hang (text "NB: We cannot know what roles the parameters to" <+>
897 quotes (ppr s1) <+> text "have;")
898 2 (text "we must assume that the role is nominal")
899 | otherwise
900 = empty
901 where
902 coercible_msg_for_tycon tc
903 | isAbstractTyCon tc
904 = Just $ hsep [ text "NB: The type constructor"
905 , quotes (pprSourceTyCon tc)
906 , text "is abstract" ]
907 | isNewTyCon tc
908 , [data_con] <- tyConDataCons tc
909 , let dc_name = dataConName data_con
910 , null (lookupGRE_Name rdr_env dc_name)
911 = Just $ hang (text "The data constructor" <+> quotes (ppr dc_name))
912 2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc)
913 , text "is not in scope" ])
914 | otherwise = Nothing
915
916 has_unknown_roles ty
917 | Just (tc, tys) <- tcSplitTyConApp_maybe ty
918 = length tys >= tyConArity tc -- oversaturated tycon
919 | Just (s, _) <- tcSplitAppTy_maybe ty
920 = has_unknown_roles s
921 | isTyVarTy ty
922 = True
923 | otherwise
924 = False
925
926 {-
927 -- | Make a listing of role signatures for all the parameterised tycons
928 -- used in the provided types
929
930
931 -- SLPJ Jun 15: I could not convince myself that these hints were really
932 -- useful. Maybe they are, but I think we need more work to make them
933 -- actually helpful.
934 mkRoleSigs :: Type -> Type -> SDoc
935 mkRoleSigs ty1 ty2
936 = ppUnless (null role_sigs) $
937 hang (text "Relevant role signatures:")
938 2 (vcat role_sigs)
939 where
940 tcs = nameEnvElts $ tyConsOfType ty1 `plusNameEnv` tyConsOfType ty2
941 role_sigs = mapMaybe ppr_role_sig tcs
942
943 ppr_role_sig tc
944 | null roles -- if there are no parameters, don't bother printing
945 = Nothing
946 | otherwise
947 = Just $ hsep $ [text "type role", ppr tc] ++ map ppr roles
948 where
949 roles = tyConRoles tc
950 -}
951
952 mkEqErr_help :: DynFlags -> ReportErrCtxt -> SDoc
953 -> Ct
954 -> Maybe SwapFlag -- Nothing <=> not sure
955 -> TcType -> TcType -> TcM ErrMsg
956 mkEqErr_help dflags ctxt extra ct oriented ty1 ty2
957 | Just tv1 <- tcGetTyVar_maybe ty1 = mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2
958 | Just tv2 <- tcGetTyVar_maybe ty2 = mkTyVarEqErr dflags ctxt extra ct swapped tv2 ty1
959 | otherwise = reportEqErr ctxt extra ct oriented ty1 ty2
960 where
961 swapped = fmap flipSwap oriented
962
963 reportEqErr :: ReportErrCtxt -> SDoc
964 -> Ct
965 -> Maybe SwapFlag -- Nothing <=> not sure
966 -> TcType -> TcType -> TcM ErrMsg
967 reportEqErr ctxt extra1 ct oriented ty1 ty2
968 = do { let extra2 = mkEqInfoMsg ct ty1 ty2
969 ; mkErrorMsgFromCt ctxt ct (vcat [ misMatchOrCND ctxt ct oriented ty1 ty2
970 , extra2, extra1]) }
971
972 mkTyVarEqErr :: DynFlags -> ReportErrCtxt -> SDoc -> Ct
973 -> Maybe SwapFlag -> TcTyVar -> TcType -> TcM ErrMsg
974 -- tv1 and ty2 are already tidied
975 mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2
976 | isUserSkolem ctxt tv1 -- ty2 won't be a meta-tyvar, or else the thing would
977 -- be oriented the other way round;
978 -- see TcCanonical.canEqTyVarTyVar
979 || isSigTyVar tv1 && not (isTyVarTy ty2)
980 || ctEqRel ct == ReprEq && not (isTyVarUnderDatatype tv1 ty2)
981 -- the cases below don't really apply to ReprEq (except occurs check)
982 = mkErrorMsgFromCt ctxt ct (vcat [ misMatchOrCND ctxt ct oriented ty1 ty2
983 , extraTyVarInfo ctxt tv1 ty2
984 , extra ])
985
986 -- So tv is a meta tyvar (or started that way before we
987 -- generalised it). So presumably it is an *untouchable*
988 -- meta tyvar or a SigTv, else it'd have been unified
989 | not (k2 `tcIsSubKind` k1) -- Kind error
990 = mkErrorMsgFromCt ctxt ct $ (kindErrorMsg (mkTyVarTy tv1) ty2 $$ extra)
991
992 | OC_Occurs <- occ_check_expand
993 , ctEqRel ct == NomEq || isTyVarUnderDatatype tv1 ty2
994 -- See Note [Occurs check error] in TcCanonical
995 = do { let occCheckMsg = addArising (ctOrigin ct) $
996 hang (text "Occurs check: cannot construct the infinite type:")
997 2 (sep [ppr ty1, char '~', ppr ty2])
998 extra2 = mkEqInfoMsg ct ty1 ty2
999 ; mkErrorMsgFromCt ctxt ct (occCheckMsg $$ extra2 $$ extra) }
1000
1001 | OC_Forall <- occ_check_expand
1002 = do { let msg = vcat [ ptext (sLit "Cannot instantiate unification variable")
1003 <+> quotes (ppr tv1)
1004 , hang (ptext (sLit "with a type involving foralls:")) 2 (ppr ty2)
1005 , nest 2 (ptext (sLit "GHC doesn't yet support impredicative polymorphism")) ]
1006 ; mkErrorMsgFromCt ctxt ct msg }
1007
1008 -- If the immediately-enclosing implication has 'tv' a skolem, and
1009 -- we know by now its an InferSkol kind of skolem, then presumably
1010 -- it started life as a SigTv, else it'd have been unified, given
1011 -- that there's no occurs-check or forall problem
1012 | (implic:_) <- cec_encl ctxt
1013 , Implic { ic_skols = skols } <- implic
1014 , tv1 `elem` skols
1015 = mkErrorMsgFromCt ctxt ct (vcat [ misMatchMsg ct oriented ty1 ty2
1016 , extraTyVarInfo ctxt tv1 ty2
1017 , extra ])
1018
1019 -- Check for skolem escape
1020 | (implic:_) <- cec_encl ctxt -- Get the innermost context
1021 , Implic { ic_env = env, ic_skols = skols, ic_info = skol_info } <- implic
1022 , let esc_skols = filter (`elemVarSet` (tyVarsOfType ty2)) skols
1023 , not (null esc_skols)
1024 = do { let msg = misMatchMsg ct oriented ty1 ty2
1025 esc_doc = sep [ ptext (sLit "because type variable") <> plural esc_skols
1026 <+> pprQuotedList esc_skols
1027 , ptext (sLit "would escape") <+>
1028 if isSingleton esc_skols then ptext (sLit "its scope")
1029 else ptext (sLit "their scope") ]
1030 tv_extra = vcat [ nest 2 $ esc_doc
1031 , sep [ (if isSingleton esc_skols
1032 then ptext (sLit "This (rigid, skolem) type variable is")
1033 else ptext (sLit "These (rigid, skolem) type variables are"))
1034 <+> ptext (sLit "bound by")
1035 , nest 2 $ ppr skol_info
1036 , nest 2 $ ptext (sLit "at") <+> ppr (tcl_loc env) ] ]
1037 ; mkErrorMsgFromCt ctxt ct (msg $$ tv_extra $$ extra) }
1038
1039 -- Nastiest case: attempt to unify an untouchable variable
1040 | (implic:_) <- cec_encl ctxt -- Get the innermost context
1041 , Implic { ic_env = env, ic_given = given, ic_info = skol_info } <- implic
1042 = do { let msg = misMatchMsg ct oriented ty1 ty2
1043 tclvl_extra
1044 = nest 2 $
1045 sep [ quotes (ppr tv1) <+> ptext (sLit "is untouchable")
1046 , nest 2 $ ptext (sLit "inside the constraints:") <+> pprEvVarTheta given
1047 , nest 2 $ ptext (sLit "bound by") <+> ppr skol_info
1048 , nest 2 $ ptext (sLit "at") <+> ppr (tcl_loc env) ]
1049 tv_extra = extraTyVarInfo ctxt tv1 ty2
1050 add_sig = suggestAddSig ctxt ty1 ty2
1051 ; mkErrorMsgFromCt ctxt ct (vcat [msg, tclvl_extra, tv_extra, add_sig, extra]) }
1052
1053 | otherwise
1054 = reportEqErr ctxt extra ct oriented (mkTyVarTy tv1) ty2
1055 -- This *can* happen (Trac #6123, and test T2627b)
1056 -- Consider an ambiguous top-level constraint (a ~ F a)
1057 -- Not an occurs check, because F is a type function.
1058 where
1059 occ_check_expand = occurCheckExpand dflags tv1 ty2
1060 k1 = tyVarKind tv1
1061 k2 = typeKind ty2
1062 ty1 = mkTyVarTy tv1
1063
1064 mkEqInfoMsg :: Ct -> TcType -> TcType -> SDoc
1065 -- Report (a) ambiguity if either side is a type function application
1066 -- e.g. F a0 ~ Int
1067 -- (b) warning about injectivity if both sides are the same
1068 -- type function application F a ~ F b
1069 -- See Note [Non-injective type functions]
1070 mkEqInfoMsg ct ty1 ty2
1071 = tyfun_msg $$ ambig_msg
1072 where
1073 mb_fun1 = isTyFun_maybe ty1
1074 mb_fun2 = isTyFun_maybe ty2
1075
1076 ambig_msg | isJust mb_fun1 || isJust mb_fun2
1077 = snd (mkAmbigMsg False ct)
1078 | otherwise = empty
1079
1080 tyfun_msg | Just tc1 <- mb_fun1
1081 , Just tc2 <- mb_fun2
1082 , tc1 == tc2
1083 = ptext (sLit "NB:") <+> quotes (ppr tc1)
1084 <+> ptext (sLit "is a type function, and may not be injective")
1085 | otherwise = empty
1086
1087 isUserSkolem :: ReportErrCtxt -> TcTyVar -> Bool
1088 -- See Note [Reporting occurs-check errors]
1089 isUserSkolem ctxt tv
1090 = isSkolemTyVar tv && any is_user_skol_tv (cec_encl ctxt)
1091 where
1092 is_user_skol_tv (Implic { ic_skols = sks, ic_info = skol_info })
1093 = tv `elem` sks && is_user_skol_info skol_info
1094
1095 is_user_skol_info (InferSkol {}) = False
1096 is_user_skol_info _ = True
1097
1098 misMatchOrCND :: ReportErrCtxt -> Ct -> Maybe SwapFlag -> TcType -> TcType -> SDoc
1099 -- If oriented then ty1 is actual, ty2 is expected
1100 misMatchOrCND ctxt ct oriented ty1 ty2
1101 | null givens ||
1102 (isRigidTy ty1 && isRigidTy ty2) ||
1103 isGivenCt ct
1104 -- If the equality is unconditionally insoluble
1105 -- or there is no context, don't report the context
1106 = misMatchMsg ct oriented ty1 ty2
1107 | otherwise
1108 = couldNotDeduce givens ([eq_pred], orig)
1109 where
1110 ev = ctEvidence ct
1111 eq_pred = ctEvPred ev
1112 orig = ctEvOrigin ev
1113 givens = [ given | given@(_, _, no_eqs, _) <- getUserGivens ctxt, not no_eqs]
1114 -- Keep only UserGivens that have some equalities
1115
1116 couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc
1117 couldNotDeduce givens (wanteds, orig)
1118 = vcat [ addArising orig (ptext (sLit "Could not deduce:") <+> pprTheta wanteds)
1119 , vcat (pp_givens givens)]
1120
1121 pp_givens :: [UserGiven] -> [SDoc]
1122 pp_givens givens
1123 = case givens of
1124 [] -> []
1125 (g:gs) -> ppr_given (ptext (sLit "from the context:")) g
1126 : map (ppr_given (ptext (sLit "or from:"))) gs
1127 where
1128 ppr_given herald (gs, skol_info, _, loc)
1129 = hang (herald <+> pprEvVarTheta gs)
1130 2 (sep [ ptext (sLit "bound by") <+> ppr skol_info
1131 , ptext (sLit "at") <+> ppr loc])
1132
1133 extraTyVarInfo :: ReportErrCtxt -> TcTyVar -> TcType -> SDoc
1134 -- Add on extra info about skolem constants
1135 -- NB: The types themselves are already tidied
1136 extraTyVarInfo ctxt tv1 ty2
1137 = tv_extra tv1 $$ ty_extra ty2
1138 where
1139 implics = cec_encl ctxt
1140 ty_extra ty = case tcGetTyVar_maybe ty of
1141 Just tv -> tv_extra tv
1142 Nothing -> empty
1143
1144 tv_extra tv | isTcTyVar tv, isSkolemTyVar tv
1145 , let pp_tv = quotes (ppr tv)
1146 = case tcTyVarDetails tv of
1147 SkolemTv {} -> pp_tv <+> pprSkol (getSkolemInfo implics tv) (getSrcLoc tv)
1148 FlatSkol {} -> pp_tv <+> ptext (sLit "is a flattening type variable")
1149 RuntimeUnk {} -> pp_tv <+> ptext (sLit "is an interactive-debugger skolem")
1150 MetaTv {} -> empty
1151
1152 | otherwise -- Normal case
1153 = empty
1154
1155 suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> SDoc
1156 -- See Note [Suggest adding a type signature]
1157 suggestAddSig ctxt ty1 ty2
1158 | null inferred_bndrs
1159 = empty
1160 | [bndr] <- inferred_bndrs
1161 = ptext (sLit "Possible fix: add a type signature for") <+> quotes (ppr bndr)
1162 | otherwise
1163 = ptext (sLit "Possible fix: add type signatures for some or all of") <+> (ppr inferred_bndrs)
1164 where
1165 inferred_bndrs = nub (get_inf ty1 ++ get_inf ty2)
1166 get_inf ty | Just tv <- tcGetTyVar_maybe ty
1167 , isTcTyVar tv, isSkolemTyVar tv
1168 , InferSkol prs <- getSkolemInfo (cec_encl ctxt) tv
1169 = map fst prs
1170 | otherwise
1171 = []
1172
1173 kindErrorMsg :: TcType -> TcType -> SDoc -- Types are already tidy
1174 kindErrorMsg ty1 ty2
1175 = vcat [ ptext (sLit "Kind incompatibility when matching types:")
1176 , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1
1177 , ppr ty2 <+> dcolon <+> ppr k2 ]) ]
1178 where
1179 k1 = typeKind ty1
1180 k2 = typeKind ty2
1181
1182 --------------------
1183 misMatchMsg :: Ct -> Maybe SwapFlag -> TcType -> TcType -> SDoc
1184 -- Types are already tidy
1185 -- If oriented then ty1 is actual, ty2 is expected
1186 misMatchMsg ct oriented ty1 ty2
1187 | Just NotSwapped <- oriented
1188 = misMatchMsg ct (Just IsSwapped) ty2 ty1
1189
1190 | otherwise -- So now we have Nothing or (Just IsSwapped)
1191 -- For some reason we treat Nothign like IsSwapped
1192 = addArising orig $
1193 sep [ text herald1 <+> quotes (ppr ty1)
1194 , nest padding $
1195 text herald2 <+> quotes (ppr ty2)
1196 , sameOccExtra ty2 ty1 ]
1197 where
1198 herald1 = conc [ "Couldn't match"
1199 , if is_repr then "representation of" else ""
1200 , if is_oriented then "expected" else ""
1201 , what ]
1202 herald2 = conc [ "with"
1203 , if is_repr then "that of" else ""
1204 , if is_oriented then ("actual " ++ what) else "" ]
1205 padding = length herald1 - length herald2
1206
1207 is_repr = case ctEqRel ct of { ReprEq -> True; NomEq -> False }
1208 is_oriented = isJust oriented
1209
1210 orig = ctOrigin ct
1211 what | isKind ty1 = "kind"
1212 | otherwise = "type"
1213
1214 conc :: [String] -> String
1215 conc = foldr1 add_space
1216
1217 add_space :: String -> String -> String
1218 add_space s1 s2 | null s1 = s2
1219 | null s2 = s1
1220 | otherwise = s1 ++ (' ' : s2)
1221
1222 mkExpectedActualMsg :: Type -> Type -> CtOrigin -> Bool
1223 -> (Maybe SwapFlag, SDoc)
1224 -- NotSwapped means (actual, expected), IsSwapped is the reverse
1225 mkExpectedActualMsg ty1 ty2
1226 (TypeEqOrigin { uo_actual = act, uo_expected = exp }) printExpanded
1227 | act `pickyEqType` ty1, exp `pickyEqType` ty2 = (Just NotSwapped, empty)
1228 | exp `pickyEqType` ty1, act `pickyEqType` ty2 = (Just IsSwapped, empty)
1229 | otherwise = (Nothing, msg)
1230 where
1231 msg = vcat
1232 [ text "Expected type:" <+> ppr exp
1233 , text " Actual type:" <+> ppr act
1234 , if printExpanded then expandedTys else empty
1235 ]
1236
1237 expandedTys =
1238 ppUnless (expTy1 `pickyEqType` exp && expTy2 `pickyEqType` act) $ vcat
1239 [ text "Type synonyms expanded:"
1240 , text "Expected type:" <+> ppr expTy1
1241 , text " Actual type:" <+> ppr expTy2
1242 ]
1243
1244 (expTy1, expTy2) = expandSynonymsToMatch exp act
1245
1246 mkExpectedActualMsg _ _ _ _ = panic "mkExpectedAcutalMsg"
1247
1248 pickyEqType :: TcType -> TcType -> Bool
1249 -- ^ Check when two types _look_ the same, _including_ synonyms.
1250 -- So (pickyEqType String [Char]) returns False
1251 pickyEqType ty1 ty2
1252 = go init_env ty1 ty2
1253 where
1254 init_env =
1255 mkRnEnv2 (mkInScopeSet (tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2))
1256 go env (TyVarTy tv1) (TyVarTy tv2) =
1257 rnOccL env tv1 == rnOccR env tv2
1258 go _ (LitTy lit1) (LitTy lit2) =
1259 lit1 == lit2
1260 go env (ForAllTy tv1 t1) (ForAllTy tv2 t2) =
1261 go env (tyVarKind tv1) (tyVarKind tv2) && go (rnBndr2 env tv1 tv2) t1 t2
1262 go env (AppTy s1 t1) (AppTy s2 t2) =
1263 go env s1 s2 && go env t1 t2
1264 go env (FunTy s1 t1) (FunTy s2 t2) =
1265 go env s1 s2 && go env t1 t2
1266 go env (TyConApp tc1 ts1) (TyConApp tc2 ts2) =
1267 (tc1 == tc2) && gos env ts1 ts2
1268 go _ _ _ =
1269 False
1270
1271 gos _ [] [] = True
1272 gos env (t1:ts1) (t2:ts2) = go env t1 t2 && gos env ts1 ts2
1273 gos _ _ _ = False
1274
1275 {-
1276 Note [Expanding type synonyms to make types similar]
1277 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1278
1279 In type error messages, if -fprint-expanded-types is used, we want to expand
1280 type synonyms to make expected and found types as similar as possible, but we
1281 shouldn't expand types too much to make type messages even more verbose and
1282 harder to understand. The whole point here is to make the difference in expected
1283 and found types clearer.
1284
1285 `expandSynonymsToMatch` does this, it takes two types, and expands type synonyms
1286 only as much as necessary. It should work like this:
1287
1288 Given two types t1 and t2:
1289
1290 * If they're already same, it shouldn't expand any type synonyms and
1291 just return.
1292
1293 * If they're in form `C1 t1_1 .. t1_n` and `C2 t2_1 .. t2_m` (C1 and C2 are
1294 type constructors), it should expand C1 and C2 if they're different type
1295 synonyms. Then it should continue doing same thing on expanded types. If C1
1296 and C2 are same, then we should apply same procedure to arguments of C1
1297 and argument of C2 to make them as similar as possible.
1298
1299 Most important thing here is to keep number of synonym expansions at
1300 minimum. For example, if t1 is `T (T3, T5, Int)` and t2 is
1301 `T (T5, T3, Bool)` where T5 = T4, T4 = T3, ..., T1 = X, we should return
1302 `T (T3, T3, Int)` and `T (T3, T3, Bool)`.
1303
1304 In the implementation, we just search in all possible solutions for a solution
1305 that does minimum amount of expansions. This leads to a complex algorithm: If
1306 we have two synonyms like X_m = X_{m-1} = .. X and Y_n = Y_{n-1} = .. Y, where
1307 X and Y are rigid types, we expand m * n times. But in practice it's not a
1308 problem because deeply nested synonyms with no intervening rigid type
1309 constructors are vanishingly rare.
1310
1311 -}
1312
1313 -- | Expand type synonyms in given types only enough to make them as equal as
1314 -- possible. Returned types are the same in terms of used type synonyms.
1315 --
1316 -- To expand all synonyms, see 'Type.expandTypeSynonyms'.
1317 expandSynonymsToMatch :: Type -> Type -> (Type, Type)
1318 expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret)
1319 where
1320 (_, ty1_ret, ty2_ret) = go 0 ty1 ty2
1321
1322 -- | Returns (number of synonym expansions done to make types similar,
1323 -- type synonym expanded version of first type,
1324 -- type synonym expanded version of second type)
1325 --
1326 -- Int argument is number of synonym expansions done so far.
1327 go :: Int -> Type -> Type -> (Int, Type, Type)
1328 go exps t1 t2
1329 | t1 `pickyEqType` t2 =
1330 -- Types are same, nothing to do
1331 (exps, t1, t2)
1332
1333 go exps t1@(TyConApp tc1 tys1) t2@(TyConApp tc2 tys2)
1334 | tc1 == tc2 =
1335 -- Type constructors are same. They may be synonyms, but we don't
1336 -- expand further.
1337 let (exps', tys1', tys2') = unzip3 $ zipWith (go 0) tys1 tys2
1338 in (exps + sum exps', TyConApp tc1 tys1', TyConApp tc2 tys2')
1339 | otherwise =
1340 -- Try to expand type constructors
1341 case (tcView t1, tcView t2) of
1342 -- When only one of the constructors is a synonym, we just
1343 -- expand it and continue search
1344 (Just t1', Nothing) ->
1345 go (exps + 1) t1' t2
1346 (Nothing, Just t2') ->
1347 go (exps + 1) t1 t2'
1348 (Just t1', Just t2') ->
1349 -- Both constructors are synonyms, but they may be synonyms of
1350 -- each other. We just search for minimally expanded solution.
1351 -- See Note [Expanding type synonyms to make types similar].
1352 let sol1@(exp1, _, _) = go (exps + 1) t1' t2
1353 sol2@(exp2, _, _) = go (exps + 1) t1 t2'
1354 in if exp1 < exp2 then sol1 else sol2
1355 (Nothing, Nothing) ->
1356 -- None of the constructors are synonyms, nothing to do
1357 (exps, t1, t2)
1358
1359 go exps t1@TyConApp{} t2
1360 | Just t1' <- tcView t1 = go (exps + 1) t1' t2
1361 | otherwise = (exps, t1, t2)
1362
1363 go exps t1 t2@TyConApp{}
1364 | Just t2' <- tcView t2 = go (exps + 1) t1 t2'
1365 | otherwise = (exps, t1, t2)
1366
1367 go exps (AppTy t1_1 t1_2) (AppTy t2_1 t2_2) =
1368 let (exps1, t1_1', t2_1') = go 0 t1_1 t2_1
1369 (exps2, t1_2', t2_2') = go 0 t1_2 t2_2
1370 in (exps + exps1 + exps2, mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2')
1371
1372 go exps (FunTy t1_1 t1_2) (FunTy t2_1 t2_2) =
1373 let (exps1, t1_1', t2_1') = go 0 t1_1 t2_1
1374 (exps2, t1_2', t2_2') = go 0 t1_2 t2_2
1375 in (exps + exps1 + exps2, FunTy t1_1' t1_2', FunTy t2_1' t2_2')
1376
1377 go exps (ForAllTy tv1 t1) (ForAllTy tv2 t2) =
1378 -- NOTE: We may have a bug here, but we just can't reproduce it easily.
1379 -- See D1016 comments for details and our attempts at producing a test
1380 -- case.
1381 let (exps1, t1', t2') = go exps t1 t2
1382 in (exps1, ForAllTy tv1 t1', ForAllTy tv2 t2')
1383
1384 go exps t1 t2 = (exps, t1, t2)
1385
1386 sameOccExtra :: TcType -> TcType -> SDoc
1387 -- See Note [Disambiguating (X ~ X) errors]
1388 sameOccExtra ty1 ty2
1389 | Just (tc1, _) <- tcSplitTyConApp_maybe ty1
1390 , Just (tc2, _) <- tcSplitTyConApp_maybe ty2
1391 , let n1 = tyConName tc1
1392 n2 = tyConName tc2
1393 same_occ = nameOccName n1 == nameOccName n2
1394 same_pkg = moduleUnitId (nameModule n1) == moduleUnitId (nameModule n2)
1395 , n1 /= n2 -- Different Names
1396 , same_occ -- but same OccName
1397 = ptext (sLit "NB:") <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2)
1398 | otherwise
1399 = empty
1400 where
1401 ppr_from same_pkg nm
1402 | isGoodSrcSpan loc
1403 = hang (quotes (ppr nm) <+> ptext (sLit "is defined at"))
1404 2 (ppr loc)
1405 | otherwise -- Imported things have an UnhelpfulSrcSpan
1406 = hang (quotes (ppr nm))
1407 2 (sep [ ptext (sLit "is defined in") <+> quotes (ppr (moduleName mod))
1408 , ppUnless (same_pkg || pkg == mainUnitId) $
1409 nest 4 $ ptext (sLit "in package") <+> quotes (ppr pkg) ])
1410 where
1411 pkg = moduleUnitId mod
1412 mod = nameModule nm
1413 loc = nameSrcSpan nm
1414
1415 {-
1416 Note [Suggest adding a type signature]
1417 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1418 The OutsideIn algorithm rejects GADT programs that don't have a principal
1419 type, and indeed some that do. Example:
1420 data T a where
1421 MkT :: Int -> T Int
1422
1423 f (MkT n) = n
1424
1425 Does this have type f :: T a -> a, or f :: T a -> Int?
1426 The error that shows up tends to be an attempt to unify an
1427 untouchable type variable. So suggestAddSig sees if the offending
1428 type variable is bound by an *inferred* signature, and suggests
1429 adding a declared signature instead.
1430
1431 This initially came up in Trac #8968, concerning pattern synonyms.
1432
1433 Note [Disambiguating (X ~ X) errors]
1434 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1435 See Trac #8278
1436
1437 Note [Reporting occurs-check errors]
1438 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1439 Given (a ~ [a]), if 'a' is a rigid type variable bound by a user-supplied
1440 type signature, then the best thing is to report that we can't unify
1441 a with [a], because a is a skolem variable. That avoids the confusing
1442 "occur-check" error message.
1443
1444 But nowadays when inferring the type of a function with no type signature,
1445 even if there are errors inside, we still generalise its signature and
1446 carry on. For example
1447 f x = x:x
1448 Here we will infer somethiing like
1449 f :: forall a. a -> [a]
1450 with a suspended error of (a ~ [a]). So 'a' is now a skolem, but not
1451 one bound by the programmer! Here we really should report an occurs check.
1452
1453 So isUserSkolem distinguishes the two.
1454
1455 Note [Non-injective type functions]
1456 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1457 It's very confusing to get a message like
1458 Couldn't match expected type `Depend s'
1459 against inferred type `Depend s1'
1460 so mkTyFunInfoMsg adds:
1461 NB: `Depend' is type function, and hence may not be injective
1462
1463 Warn of loopy local equalities that were dropped.
1464
1465
1466 ************************************************************************
1467 * *
1468 Type-class errors
1469 * *
1470 ************************************************************************
1471 -}
1472
1473 mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
1474 mkDictErr ctxt cts
1475 = ASSERT( not (null cts) )
1476 do { inst_envs <- tcGetInstEnvs
1477 ; let (ct1:_) = cts -- ct1 just for its location
1478 min_cts = elim_superclasses cts
1479 ; lookups <- mapM (lookup_cls_inst inst_envs) min_cts
1480 ; let (no_inst_cts, overlap_cts) = partition is_no_inst lookups
1481
1482 -- Report definite no-instance errors,
1483 -- or (iff there are none) overlap errors
1484 -- But we report only one of them (hence 'head') because they all
1485 -- have the same source-location origin, to try avoid a cascade
1486 -- of error from one location
1487 ; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts))
1488 ; mkErrorMsgFromCt ctxt ct1 err }
1489 where
1490 no_givens = null (getUserGivens ctxt)
1491
1492 is_no_inst (ct, (matches, unifiers, _))
1493 = no_givens
1494 && null matches
1495 && (null unifiers || all (not . isAmbiguousTyVar) (varSetElems (tyVarsOfCt ct)))
1496
1497 lookup_cls_inst inst_envs ct
1498 = do { tys_flat <- mapM quickFlattenTy tys
1499 -- Note [Flattening in error message generation]
1500 ; return (ct, lookupInstEnv True inst_envs clas tys_flat) }
1501 where
1502 (clas, tys) = getClassPredTys (ctPred ct)
1503
1504
1505 -- When simplifying [W] Ord (Set a), we need
1506 -- [W] Eq a, [W] Ord a
1507 -- but we really only want to report the latter
1508 elim_superclasses cts
1509 = filter (\ct -> any (eqPred (ctPred ct)) min_preds) cts
1510 where
1511 min_preds = mkMinimalBySCs (map ctPred cts)
1512
1513 mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult)
1514 -> TcM (ReportErrCtxt, SDoc)
1515 -- Report an overlap error if this class constraint results
1516 -- from an overlap (returning Left clas), otherwise return (Right pred)
1517 mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped))
1518 | null matches -- No matches but perhaps several unifiers
1519 = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
1520 ; return (ctxt, cannot_resolve_msg ct binds_msg) }
1521
1522 | null unsafe_overlapped -- Some matches => overlap errors
1523 = return (ctxt, overlap_msg)
1524
1525 | otherwise
1526 = return (ctxt, safe_haskell_msg)
1527 where
1528 orig = ctOrigin ct
1529 pred = ctPred ct
1530 (clas, tys) = getClassPredTys pred
1531 ispecs = [ispec | (ispec, _) <- matches]
1532 unsafe_ispecs = [ispec | (ispec, _) <- unsafe_overlapped]
1533 givens = getUserGivens ctxt
1534 all_tyvars = all isTyVarTy tys
1535
1536
1537 cannot_resolve_msg :: Ct -> SDoc -> SDoc
1538 cannot_resolve_msg ct binds_msg
1539 = vcat [ no_inst_msg
1540 , nest 2 extra_note
1541 , vcat (pp_givens givens)
1542 , ppWhen (has_ambig_tvs && not (null unifiers && null givens))
1543 (vcat [ ppUnless lead_with_ambig ambig_msg, binds_msg, potential_msg ])
1544 , show_fixes (add_to_ctxt_fixes has_ambig_tvs ++ drv_fixes) ]
1545 where
1546 orig = ctOrigin ct
1547 -- See Note [Highlighting ambiguous type variables]
1548 lead_with_ambig = has_ambig_tvs && not (any isRuntimeUnkSkol ambig_tvs)
1549 && not (null unifiers) && null givens
1550
1551 (has_ambig_tvs, ambig_msg) = mkAmbigMsg lead_with_ambig ct
1552 ambig_tvs = getAmbigTkvs ct
1553
1554 no_inst_msg
1555 | lead_with_ambig
1556 = ambig_msg <+> pprArising orig
1557 $$ text "prevents the constraint" <+> quotes (pprParendType pred)
1558 <+> text "from being solved."
1559
1560 | null givens
1561 = addArising orig $ text "No instance for"
1562 <+> pprParendType pred
1563
1564 | otherwise
1565 = addArising orig $ text "Could not deduce"
1566 <+> pprParendType pred
1567
1568 potential_msg
1569 = ppWhen (not (null unifiers) && want_potential orig) $
1570 sdocWithDynFlags $ \dflags ->
1571 getPprStyle $ \sty ->
1572 pprPotentials dflags sty potential_hdr unifiers
1573
1574 potential_hdr
1575 = vcat [ ppWhen lead_with_ambig $
1576 text "Probable fix: use a type annotation to specify what"
1577 <+> pprQuotedList ambig_tvs <+> text "should be."
1578 , ptext (sLit "These potential instance") <> plural unifiers
1579 <+> text "exist:"]
1580
1581 -- Report "potential instances" only when the constraint arises
1582 -- directly from the user's use of an overloaded function
1583 want_potential (TypeEqOrigin {}) = False
1584 want_potential _ = True
1585
1586 add_to_ctxt_fixes has_ambig_tvs
1587 | not has_ambig_tvs && all_tyvars
1588 , (orig:origs) <- usefulContext ctxt pred
1589 = [sep [ ptext (sLit "add") <+> pprParendType pred
1590 <+> ptext (sLit "to the context of")
1591 , nest 2 $ ppr_skol orig $$
1592 vcat [ ptext (sLit "or") <+> ppr_skol orig
1593 | orig <- origs ] ] ]
1594 | otherwise = []
1595
1596 ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc)
1597 ppr_skol skol_info = ppr skol_info
1598
1599 extra_note | any isFunTy (filterOut isKind tys)
1600 = ptext (sLit "(maybe you haven't applied a function to enough arguments?)")
1601 | className clas == typeableClassName -- Avoid mysterious "No instance for (Typeable T)
1602 , [_,ty] <- tys -- Look for (Typeable (k->*) (T k))
1603 , Just (tc,_) <- tcSplitTyConApp_maybe ty
1604 , not (isTypeFamilyTyCon tc)
1605 = hang (ptext (sLit "GHC can't yet do polykinded"))
1606 2 (ptext (sLit "Typeable") <+> parens (ppr ty <+> dcolon <+> ppr (typeKind ty)))
1607 | otherwise
1608 = empty
1609
1610 drv_fixes = case orig of
1611 DerivOrigin -> [drv_fix]
1612 DerivOriginDC {} -> [drv_fix]
1613 DerivOriginCoerce {} -> [drv_fix]
1614 _ -> []
1615
1616 drv_fix = hang (ptext (sLit "use a standalone 'deriving instance' declaration,"))
1617 2 (ptext (sLit "so you can specify the instance context yourself"))
1618
1619 -- Normal overlap error
1620 overlap_msg
1621 = ASSERT( not (null matches) )
1622 vcat [ addArising orig (ptext (sLit "Overlapping instances for")
1623 <+> pprType (mkClassPred clas tys))
1624
1625 , ppUnless (null matching_givens) $
1626 sep [ptext (sLit "Matching givens (or their superclasses):")
1627 , nest 2 (vcat matching_givens)]
1628
1629 , sdocWithDynFlags $ \dflags ->
1630 getPprStyle $ \sty ->
1631 pprPotentials dflags sty (ptext (sLit "Matching instances:")) $
1632 ispecs ++ unifiers
1633
1634 , ppWhen (null matching_givens && isSingleton matches && null unifiers) $
1635 -- Intuitively, some given matched the wanted in their
1636 -- flattened or rewritten (from given equalities) form
1637 -- but the matcher can't figure that out because the
1638 -- constraints are non-flat and non-rewritten so we
1639 -- simply report back the whole given
1640 -- context. Accelerate Smart.hs showed this problem.
1641 sep [ ptext (sLit "There exists a (perhaps superclass) match:")
1642 , nest 2 (vcat (pp_givens givens))]
1643
1644 , ppWhen (isSingleton matches) $
1645 parens (vcat [ ptext (sLit "The choice depends on the instantiation of") <+>
1646 quotes (pprWithCommas ppr (varSetElems (tyVarsOfTypes tys)))
1647 , ppWhen (null (matching_givens)) $
1648 vcat [ ptext (sLit "To pick the first instance above, use IncoherentInstances")
1649 , ptext (sLit "when compiling the other instance declarations")]
1650 ])]
1651 where
1652 givens = getUserGivens ctxt
1653 matching_givens = mapMaybe matchable givens
1654
1655 matchable (evvars,skol_info,_,loc)
1656 = case ev_vars_matching of
1657 [] -> Nothing
1658 _ -> Just $ hang (pprTheta ev_vars_matching)
1659 2 (sep [ ptext (sLit "bound by") <+> ppr skol_info
1660 , ptext (sLit "at") <+> ppr loc])
1661 where ev_vars_matching = filter ev_var_matches (map evVarPred evvars)
1662 ev_var_matches ty = case getClassPredTys_maybe ty of
1663 Just (clas', tys')
1664 | clas' == clas
1665 , Just _ <- tcMatchTys (tyVarsOfTypes tys) tys tys'
1666 -> True
1667 | otherwise
1668 -> any ev_var_matches (immSuperClasses clas' tys')
1669 Nothing -> False
1670
1671 -- Overlap error because of Safe Haskell (first
1672 -- match should be the most specific match)
1673 safe_haskell_msg
1674 = ASSERT( length matches == 1 && not (null unsafe_ispecs) )
1675 vcat [ addArising orig (ptext (sLit "Unsafe overlapping instances for")
1676 <+> pprType (mkClassPred clas tys))
1677 , sep [ptext (sLit "The matching instance is:"),
1678 nest 2 (pprInstance $ head ispecs)]
1679 , vcat [ ptext $ sLit "It is compiled in a Safe module and as such can only"
1680 , ptext $ sLit "overlap instances from the same module, however it"
1681 , ptext $ sLit "overlaps the following instances from different modules:"
1682 , nest 2 (vcat [pprInstances $ unsafe_ispecs])
1683 ]
1684 ]
1685
1686 {- Note [Highlighting ambiguous type variables]
1687 -----------------------------------------------
1688 When we encounter ambiguous type variables (i.e. type variables
1689 that remain metavariables after type inference), we need a few more
1690 conditions before we can reason that *ambiguity* prevents constraints
1691 from being solved:
1692 - We can't have any givens, as encountering a typeclass error
1693 with given constraints just means we couldn't deduce
1694 a solution satisfying those constraints and as such couldn't
1695 bind the type variable to a known type.
1696 - If we don't have any unifiers, we don't even have potential
1697 instances from which an ambiguity could arise.
1698 - Lastly, I don't want to mess with error reporting for
1699 unknown runtime types so we just fall back to the old message there.
1700 Once these conditions are satisfied, we can safely say that ambiguity prevents
1701 the constraint from being solved. -}
1702
1703
1704 usefulContext :: ReportErrCtxt -> TcPredType -> [SkolemInfo]
1705 usefulContext ctxt pred
1706 = go (cec_encl ctxt)
1707 where
1708 pred_tvs = tyVarsOfType pred
1709 go [] = []
1710 go (ic : ics)
1711 | implausible ic = rest
1712 | otherwise = ic_info ic : rest
1713 where
1714 -- Stop when the context binds a variable free in the predicate
1715 rest | any (`elemVarSet` pred_tvs) (ic_skols ic) = []
1716 | otherwise = go ics
1717
1718 implausible ic
1719 | null (ic_skols ic) = True
1720 | implausible_info (ic_info ic) = True
1721 | otherwise = False
1722
1723 implausible_info (SigSkol (InfSigCtxt {}) _) = True
1724 implausible_info _ = False
1725 -- Do not suggest adding constraints to an *inferred* type signature!
1726
1727 show_fixes :: [SDoc] -> SDoc
1728 show_fixes [] = empty
1729 show_fixes (f:fs) = sep [ ptext (sLit "Possible fix:")
1730 , nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
1731
1732 pprPotentials :: DynFlags -> PprStyle -> SDoc -> [ClsInst] -> SDoc
1733 -- See Note [Displaying potential instances]
1734 pprPotentials dflags sty herald insts
1735 | null insts
1736 = empty
1737
1738 | null show_these
1739 = hang herald
1740 2 (vcat [ not_in_scope_msg empty
1741 , flag_hint ])
1742
1743 | otherwise
1744 = hang herald
1745 2 (vcat [ pprInstances show_these
1746 , ppWhen (n_in_scope_hidden > 0) $
1747 ptext (sLit "...plus")
1748 <+> speakNOf n_in_scope_hidden (ptext (sLit "other"))
1749 , not_in_scope_msg (ptext (sLit "...plus"))
1750 , flag_hint ])
1751 where
1752 n_show = 3 :: Int
1753 show_potentials = gopt Opt_PrintPotentialInstances dflags
1754
1755 (in_scope, not_in_scope) = partition inst_in_scope insts
1756 sorted = sortBy fuzzyClsInstCmp in_scope
1757 show_these | show_potentials = sorted
1758 | otherwise = take n_show sorted
1759 n_in_scope_hidden = length sorted - length show_these
1760
1761 -- "in scope" means that all the type constructors
1762 -- are lexically in scope; these instances are likely
1763 -- to be more useful
1764 inst_in_scope :: ClsInst -> Bool
1765 inst_in_scope cls_inst = foldNameSet ((&&) . name_in_scope) True $
1766 orphNamesOfTypes (is_tys cls_inst)
1767
1768 name_in_scope name
1769 | isBuiltInSyntax name
1770 = True -- E.g. (->)
1771 | Just mod <- nameModule_maybe name
1772 = qual_in_scope (qualName sty mod (nameOccName name))
1773 | otherwise
1774 = True
1775
1776 qual_in_scope :: QualifyName -> Bool
1777 qual_in_scope NameUnqual = True
1778 qual_in_scope (NameQual {}) = True
1779 qual_in_scope _ = False
1780
1781 not_in_scope_msg herald
1782 | null not_in_scope
1783 = empty
1784 | otherwise
1785 = hang (herald <+> speakNOf (length not_in_scope)
1786 (ptext (sLit "instance involving out-of-scope types")))
1787 2 (ppWhen show_potentials (pprInstances not_in_scope))
1788
1789 flag_hint = ppUnless (show_potentials || length show_these == length insts) $
1790 ptext (sLit "(use -fprint-potential-instances to see them all)")
1791
1792 {- Note [Displaying potential instances]
1793 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1794 When showing a list of instances for
1795 - overlapping instances (show ones that match)
1796 - no such instance (show ones that could match)
1797 we want to give it a bit of structure. Here's the plan
1798
1799 * Say that an instance is "in scope" if all of the
1800 type constructors it mentions are lexically in scope.
1801 These are the ones most likely to be useful to the programmer.
1802
1803 * Show at most n_show in-scope instances,
1804 and summarise the rest ("plus 3 others")
1805
1806 * Summarise the not-in-scope instances ("plus 4 not in scope")
1807
1808 * Add the flag -fshow-potential-instances which replaces the
1809 summary with the full list
1810 -}
1811
1812 quickFlattenTy :: TcType -> TcM TcType
1813 -- See Note [Flattening in error message generation]
1814 quickFlattenTy ty | Just ty' <- tcView ty = quickFlattenTy ty'
1815 quickFlattenTy ty@(TyVarTy {}) = return ty
1816 quickFlattenTy ty@(ForAllTy {}) = return ty -- See
1817 quickFlattenTy ty@(LitTy {}) = return ty
1818 -- Don't flatten because of the danger or removing a bound variable
1819 quickFlattenTy (AppTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
1820 ; fy2 <- quickFlattenTy ty2
1821 ; return (AppTy fy1 fy2) }
1822 quickFlattenTy (FunTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
1823 ; fy2 <- quickFlattenTy ty2
1824 ; return (FunTy fy1 fy2) }
1825 quickFlattenTy (TyConApp tc tys)
1826 | not (isTypeFamilyTyCon tc)
1827 = do { fys <- mapM quickFlattenTy tys
1828 ; return (TyConApp tc fys) }
1829 | otherwise
1830 = do { let (funtys,resttys) = splitAt (tyConArity tc) tys
1831 -- Ignore the arguments of the type family funtys
1832 ; v <- newMetaTyVar TauTv (typeKind (TyConApp tc funtys))
1833 ; flat_resttys <- mapM quickFlattenTy resttys
1834 ; return (foldl AppTy (mkTyVarTy v) flat_resttys) }
1835
1836 {- Note [Flattening in error message generation]
1837 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1838 Consider (C (Maybe (F x))), where F is a type function, and we have
1839 instances
1840 C (Maybe Int) and C (Maybe a)
1841 Since (F x) might turn into Int, this is an overlap situation, and
1842 indeed (because of flattening) the main solver will have refrained
1843 from solving. But by the time we get to error message generation, we've
1844 un-flattened the constraint. So we must *re*-flatten it before looking
1845 up in the instance environment, lest we only report one matching
1846 instance when in fact there are two.
1847
1848 Re-flattening is pretty easy, because we don't need to keep track of
1849 evidence. We don't re-use the code in TcCanonical because that's in
1850 the TcS monad, and we are in TcM here.
1851
1852 Note [Quick-flatten polytypes]
1853 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1854 If we see C (Ix a => blah) or C (forall a. blah) we simply refrain from
1855 flattening any further. After all, there can be no instance declarations
1856 that match such things. And flattening under a for-all is problematic
1857 anyway; consider C (forall a. F a)
1858
1859 Note [Suggest -fprint-explicit-kinds]
1860 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1861 It can be terribly confusing to get an error message like (Trac #9171)
1862 Couldn't match expected type ‘GetParam Base (GetParam Base Int)’
1863 with actual type ‘GetParam Base (GetParam Base Int)’
1864 The reason may be that the kinds don't match up. Typically you'll get
1865 more useful information, but not when it's as a result of ambiguity.
1866 This test suggests -fprint-explicit-kinds when all the ambiguous type
1867 variables are kind variables.
1868 -}
1869
1870 mkAmbigMsg :: Bool -- True when message has to be at beginning of sentence
1871 -> Ct -> (Bool, SDoc)
1872 mkAmbigMsg prepend_msg ct
1873 | null ambig_tkvs = (False, empty)
1874 | otherwise = (True, msg)
1875 where
1876 ambig_tkvs = getAmbigTkvs ct
1877 (ambig_kvs, ambig_tvs) = partition isKindVar ambig_tkvs
1878
1879 msg | any isRuntimeUnkSkol ambig_tkvs -- See Note [Runtime skolems]
1880 = vcat [ ptext (sLit "Cannot resolve unknown runtime type")
1881 <> plural ambig_tvs <+> pprQuotedList ambig_tvs
1882 , ptext (sLit "Use :print or :force to determine these types")]
1883
1884 | not (null ambig_tvs)
1885 = pp_ambig (ptext (sLit "type")) ambig_tvs
1886
1887 | otherwise -- All ambiguous kind variabes; suggest -fprint-explicit-kinds
1888 = vcat [ pp_ambig (ptext (sLit "kind")) ambig_kvs
1889 , sdocWithDynFlags suggest_explicit_kinds ]
1890
1891 pp_ambig what tkvs
1892 | prepend_msg -- "Ambiguous type variable 't0'"
1893 = ptext (sLit "Ambiguous") <+> what <+> ptext (sLit "variable")
1894 <> plural tkvs <+> pprQuotedList tkvs
1895
1896 | otherwise -- "The type variable 't0' is ambiguous"
1897 = ptext (sLit "The") <+> what <+> ptext (sLit "variable") <> plural tkvs
1898 <+> pprQuotedList tkvs <+> is_or_are tkvs <+> ptext (sLit "ambiguous")
1899
1900 is_or_are [_] = text "is"
1901 is_or_are _ = text "are"
1902
1903 suggest_explicit_kinds dflags -- See Note [Suggest -fprint-explicit-kinds]
1904 | gopt Opt_PrintExplicitKinds dflags = empty
1905 | otherwise = ptext (sLit "Use -fprint-explicit-kinds to see the kind arguments")
1906
1907 getAmbigTkvs :: Ct -> [Var]
1908 getAmbigTkvs ct
1909 = varSetElems ambig_tkv_set
1910 where
1911 ambig_tkv_set = filterVarSet isAmbiguousTyVar (tyVarsOfCt ct)
1912
1913
1914 pprSkol :: SkolemInfo -> SrcLoc -> SDoc
1915 pprSkol UnkSkol _
1916 = ptext (sLit "is an unknown type variable")
1917 pprSkol skol_info tv_loc
1918 = sep [ ptext (sLit "is a rigid type variable bound by"),
1919 sep [ppr skol_info, ptext (sLit "at") <+> ppr tv_loc]]
1920
1921 getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo
1922 -- Get the skolem info for a type variable
1923 -- from the implication constraint that binds it
1924 getSkolemInfo [] tv
1925 = pprPanic "No skolem info:" (ppr tv)
1926
1927 getSkolemInfo (implic:implics) tv
1928 | tv `elem` ic_skols implic = ic_info implic
1929 | otherwise = getSkolemInfo implics tv
1930
1931 -----------------------
1932 -- relevantBindings looks at the value environment and finds values whose
1933 -- types mention any of the offending type variables. It has to be
1934 -- careful to zonk the Id's type first, so it has to be in the monad.
1935 -- We must be careful to pass it a zonked type variable, too.
1936 --
1937 -- We always remove closed top-level bindings, though,
1938 -- since they are never relevant (cf Trac #8233)
1939
1940 relevantBindings :: Bool -- True <=> filter by tyvar; False <=> no filtering
1941 -- See Trac #8191
1942 -> ReportErrCtxt -> Ct
1943 -> TcM (ReportErrCtxt, SDoc, Ct)
1944 -- Also returns the zonked and tidied CtOrigin of the constraint
1945 relevantBindings want_filtering ctxt ct
1946 = do { dflags <- getDynFlags
1947 ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc)
1948 ; let ct_tvs = tyVarsOfCt ct `unionVarSet` extra_tvs
1949
1950 -- For *kind* errors, report the relevant bindings of the
1951 -- enclosing *type* equality, because that's more useful for the programmer
1952 extra_tvs = case tidy_orig of
1953 KindEqOrigin t1 t2 _ -> tyVarsOfTypes [t1,t2]
1954 _ -> emptyVarSet
1955 ; traceTc "relevantBindings" $
1956 vcat [ ppr ct
1957 , pprCtOrigin (ctLocOrigin loc)
1958 , ppr ct_tvs
1959 , ppr [id | TcIdBndr id _ <- tcl_bndrs lcl_env] ]
1960
1961 ; (tidy_env', docs, discards)
1962 <- go env1 ct_tvs (maxRelevantBinds dflags)
1963 emptyVarSet [] False
1964 (tcl_bndrs lcl_env)
1965 -- tcl_bndrs has the innermost bindings first,
1966 -- which are probably the most relevant ones
1967
1968 ; let doc = ppUnless (null docs) $
1969 hang (ptext (sLit "Relevant bindings include"))
1970 2 (vcat docs $$ ppWhen discards discardMsg)
1971
1972 -- Put a zonked, tidied CtOrigin into the Ct
1973 loc' = setCtLocOrigin loc tidy_orig
1974 ct' = setCtLoc ct loc'
1975 ctxt' = ctxt { cec_tidy = tidy_env' }
1976
1977 ; return (ctxt', doc, ct') }
1978 where
1979 ev = ctEvidence ct
1980 loc = ctEvLoc ev
1981 lcl_env = ctLocEnv loc
1982
1983 run_out :: Maybe Int -> Bool
1984 run_out Nothing = False
1985 run_out (Just n) = n <= 0
1986
1987 dec_max :: Maybe Int -> Maybe Int
1988 dec_max = fmap (\n -> n - 1)
1989
1990 go :: TidyEnv -> TcTyVarSet -> Maybe Int -> TcTyVarSet -> [SDoc]
1991 -> Bool -- True <=> some filtered out due to lack of fuel
1992 -> [TcIdBinder]
1993 -> TcM (TidyEnv, [SDoc], Bool) -- The bool says if we filtered any out
1994 -- because of lack of fuel
1995 go tidy_env _ _ _ docs discards []
1996 = return (tidy_env, reverse docs, discards)
1997 go tidy_env ct_tvs n_left tvs_seen docs discards (TcIdBndr id top_lvl : tc_bndrs)
1998 = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id)
1999 ; traceTc "relevantBindings 1" (ppr id <+> dcolon <+> ppr tidy_ty)
2000 ; let id_tvs = tyVarsOfType tidy_ty
2001 doc = sep [ pprPrefixOcc id <+> dcolon <+> ppr tidy_ty
2002 , nest 2 (parens (ptext (sLit "bound at")
2003 <+> ppr (getSrcLoc id)))]
2004 new_seen = tvs_seen `unionVarSet` id_tvs
2005
2006 ; if (want_filtering && not opt_PprStyle_Debug
2007 && id_tvs `disjointVarSet` ct_tvs)
2008 -- We want to filter out this binding anyway
2009 -- so discard it silently
2010 then go tidy_env ct_tvs n_left tvs_seen docs discards tc_bndrs
2011
2012 else if isTopLevel top_lvl && not (isNothing n_left)
2013 -- It's a top-level binding and we have not specified
2014 -- -fno-max-relevant-bindings, so discard it silently
2015 then go tidy_env ct_tvs n_left tvs_seen docs discards tc_bndrs
2016
2017 else if run_out n_left && id_tvs `subVarSet` tvs_seen
2018 -- We've run out of n_left fuel and this binding only
2019 -- mentions aleady-seen type variables, so discard it
2020 then go tidy_env ct_tvs n_left tvs_seen docs True tc_bndrs
2021
2022 -- Keep this binding, decrement fuel
2023 else go tidy_env' ct_tvs (dec_max n_left) new_seen (doc:docs) discards tc_bndrs }
2024
2025 discardMsg :: SDoc
2026 discardMsg = ptext (sLit "(Some bindings suppressed; use -fmax-relevant-binds=N or -fno-max-relevant-binds)")
2027
2028 -----------------------
2029 warnDefaulting :: [Ct] -> Type -> TcM ()
2030 warnDefaulting wanteds default_ty
2031 = do { warn_default <- woptM Opt_WarnTypeDefaults
2032 ; env0 <- tcInitTidyEnv
2033 ; let tidy_env = tidyFreeTyVars env0 $
2034 foldr (unionVarSet . tyVarsOfCt) emptyVarSet wanteds
2035 tidy_wanteds = map (tidyCt tidy_env) wanteds
2036 (loc, ppr_wanteds) = pprWithArising tidy_wanteds
2037 warn_msg = hang (ptext (sLit "Defaulting the following constraint(s) to type")
2038 <+> quotes (ppr default_ty))
2039 2 ppr_wanteds
2040 ; setCtLocM loc $ warnTc warn_default warn_msg }
2041
2042 {-
2043 Note [Runtime skolems]
2044 ~~~~~~~~~~~~~~~~~~~~~~
2045 We want to give a reasonably helpful error message for ambiguity
2046 arising from *runtime* skolems in the debugger. These
2047 are created by in RtClosureInspect.zonkRTTIType.
2048
2049 ************************************************************************
2050 * *
2051 Error from the canonicaliser
2052 These ones are called *during* constraint simplification
2053 * *
2054 ************************************************************************
2055 -}
2056
2057 solverDepthErrorTcS :: CtLoc -> TcType -> TcM a
2058 solverDepthErrorTcS loc ty
2059 = setCtLocM loc $
2060 do { ty <- zonkTcType ty
2061 ; env0 <- tcInitTidyEnv
2062 ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfType ty)
2063 tidy_ty = tidyType tidy_env ty
2064 msg
2065 = vcat [ text "Reduction stack overflow; size =" <+> ppr depth
2066 , hang (text "When simplifying the following type:")
2067 2 (ppr tidy_ty)
2068 , note ]
2069 ; failWithTcM (tidy_env, msg) }
2070 where
2071 depth = ctLocDepth loc
2072 note = vcat
2073 [ text "Use -freduction-depth=0 to disable this check"
2074 , text "(any upper bound you could choose might fail unpredictably with"
2075 , text " minor updates to GHC, so disabling the check is recommended if"
2076 , text " you're sure that type checking should terminate)" ]